Language/OS - Multiplatform Resource Library

home *** CD-ROM | disk | FTP | other *** search

/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / snobol4 / misc.lha / v311.sil < prev

Wrap

Text File | 1993-08-16 | 245KB | 6,581 lines

TITLE 'Table of Contents' * * * E32 (DECEMBER 18, 1969) V3.7 * UPDATED TO VERSION 3.10, NOV. 1, 1972 V3.10 * * UPDATED TO VERSION 3.11, MAY 19, 1975. V3.11 * RESEQUENCED DECEMBER 20, 1980. V3.11 * Corrected April 10, 1985 (lines 3393 and 5033). * 1. Linkage and Equivalences * Linkage * Machine Dependent Parameters * Constants * Equivalences * Data Type Codes * 2. Program Initialization * 3. Compilation and Interpreter Invocation * 4. Support Procedures * AUGATL * CODSKP * DTREP * FINDEX * 5. Storage Allocation and Regeneration Procedures * BLOCK * GENVAR * GNVARI * CONVAR * GNVARS * GC * GCM * SPLIT * 6. Compilation Procedures * BINOP * CMPILE * ELEMNT * EXPR * FORWRD * NEWCRD * TREPUB * UNOP * 7. Interpreter Executive and Control Procedures * BASE * GOTG * GOTL * GOTO * INIT * INTERP * INVOKE * 8. Argument Evaluation Procedures * ARGVAL * EXPVAL * EXPEVL * EVAL * INTVAL * PATVAL * VARVAL * XYARGS * 9. Arithmetic Operations, Predicates and Functions * ADD * DIV * EXP * MPY * SUB * EQ * GE * GT * LE * LT * NE * REMDR * INTGER * MNS * PLS * 10. Pattern-Valued Functions and Operations * ANY * BREAK * NOTANY * SPAN * LEN * POS * RPOS * RTAB * TAB * ARBNO * ATOP (Cursor Position) * NAM (Value Assignment) * OR * 11. Pattern Matching Procedures * SCAN * SJSR (Scan and Replace) * SCNR (Basic Scanner) * ANYC * BRKC * NNYC * SPNC * LNTH * POSI * RPSI * RTB * TB * ARBN (ARBNO) * FARB (ARB Backup) * ATP (Cursor Position) * BAL * CHAR * STAR (Unevaluated Expression) * DSAR * FNCE * NME (Value Assignment) * ENME * DNME * ENMI (Immediate Value Assignment) * SUCE (SUCCEED) * 12. Defined Functions * DEFINE * DEFFNC (Invoke Defined Function) * 13. External Functions * LOAD * UNLOAD * LNKFNC (Link to External Function) * 14. Arrays, Tables, and Defined Data Objects * ARRAY * ASSOC (TABLE) * DATDEF (DATA) * PROTO * ITEM (Array and Table References) * DEFDAT (Create Data Object) * FIELD * 15. Input and Output * READ (INPUT) * PRINT (OUTPUT) * BKSPCE * ENFILE * REWIND * DETACH * PUTIN * PUTOUT * 16. Tracing Procedures and Functions * TRACE * STOPTR * FENTR (Call Tracing) * FENTR2 * KEYTR * TRPHND (Trace Handler) * VALTR * FNEXT2 * 17. Other Operations * ASGN (=) * CON (Concatenation) * IND (Indirect Reference) * KEYWRD * LIT * NAME * NMD (Value Assignment) * STR (Unevaluated Expression) * 18. Other Predicates * DIFFER * IDENT * LGT * NEG * QUES (?) * 19. Other Functions * APPLY * ARG * LOCAL * FIELDS * CLEAR * COLECT * COPY * CNVRT * DATE * DT * DMP * DUMP * DUPL * OPSYN * RPLACE * SIZE * TIME * TRIM * 20. Common Code * 21. Termination * END * FTLEND * SYSCUT * 22. Error Handling * 23. Data * Pair Lists * Data Type Pairs * Switches * Constants * Pointers to Patterns * Function Descriptors * Miscellaneous Data * Program Pointers * Pointers to Specifiers * Permanent Pair List Pointers * Specifiers for Compilation * Strings and Specifiers * Character Buffers * Pointers to Pair Lists * Scratch Descriptors * System Descriptors * Compiler Descriptors * Data Pointers * Specifiers * Allocator Data * Machine Dependent Data * Function Table * Function Pair List * Function Initialization Data * Pointers to Initialization Data * System Arrays * String Storage Bin List * Pattern-Matching History List * System Stack * Primitive Patterns * Code Skeleton for TRACE * Fatal Error Message Pointers * Fatal Error Messages * Compiler Error Messages * Formats * TITLE 'Linkage and Equivalences' COPY MLINK Linkage segment COPY PARMS Machine-dependent parameters * * Constants * ATTRIB EQU 2*DESCR Offset of label in string structure LNKFLD EQU 3*DESCR Offset of link in string structure BCDFLD EQU 4*DESCR Offset of string in string structure FATHER EQU DESCR Offset of father in code node LSON EQU 2*DESCR Offset of left son in code node RSIB EQU 3*DESCR Offset of right sibling in code node CODE EQU 4*DESCR Offset of code in code node ESASIZ EQU 50 Limit on number of syntactic errors FBLKSZ EQU 10*DESCR Size of function descriptor block ARRLEN EQU 20 Limit on length of array print image CARDSZ EQU 80 Width of compiler input SEQSIZ EQU 8 Width of sequence field STNOSZ EQU 8 Length of statement number field DSTSZ EQU 2*STNOSZ Space for left and right numbering CNODSZ EQU 4*DESCR Size of code node DATSIZ EQU 1000 Limit on number of defined data type EXTSIZ EQU 10 Default allocation for tables NAMLSZ EQU 20 Growth quantum for name list NODESZ EQU 3*DESCR Size of pattern node OBSIZ EQU 256 Number of bin headers OBARY EQU OBSIZ+3 Total number for bins OCASIZ EQU 1500 Descriptors of initial object code SPDLSZ EQU 1000 Descriptors of pattern stack STSIZE EQU 1000 Descriptors of interpreter stack SPDR EQU SPEC+DESCR Descriptor plus specifier OBOFF EQU OBSIZ-2 Offset length in bins SPDLDR EQU SPDLSZ*DESCR Size of pattern stack * * Equivalences * ARYTYP EQU 7 Array reference CLNTYP EQU 5 Goto field CMATYP EQU 2 Comma CMTTYP EQU 2 Comment card CNTTYP EQU 4 Continue card CTLTYP EQU 3 Control card DIMTYP EQU 1 Dimension separator EOSTYP EQU 6 End of statement EQTYP EQU 4 Equal sign FGOTYP EQU 3 Failure goto FTOTYP EQU 6 Failure direct goto FLITYP EQU 6 Literal real FNCTYP EQU 5 Function call ILITYP EQU 2 Literal integer LPTYP EQU 1 Left parenthesis NBTYP EQU 1 Nonbreak character NEWTYP EQU 1 New statement NSTTYP EQU 4 Parenthesized expression QLITYP EQU 1 Quoted literal RBTYP EQU 7 Right bracket RPTYP EQU 3 Right parenthesis SGOTYP EQU 2 Success goto STOTYP EQU 5 Success direct goto UGOTYP EQU 1 Unconditional goto UTOTYP EQU 4 Unconditional direct goto VARTYP EQU 3 Variable * * Data type Codes * A EQU 4 ARRAY B EQU 2 BLOCK (internal) C EQU 8 CODE E EQU 11 EXPRESSION I EQU 6 INTEGER K EQU 10 KEYWORD (NAME) L EQU 12 LINKED STRING (internal) N EQU 9 NAME P EQU 3 PATTERN R EQU 7 REAL S EQU 1 STRING T EQU 5 TABLE *---------------------------------------------------------------------* TITLE 'Program Initialization' BEGIN INIT , Initialize system ISTACK , Initialize stack OUTPUT OUTPUT,TITLEF Title listing OUTPUT OUTPUT,SOURCF Print attribution MSTIME TIMECL Time in compiler RCALL SCBSCL,BLOCK,OCALIM Allocate block for object code MOVD OCSVCL,SCBSCL Save object code pointer RESETF SCBSCL,PTR Clear pointer flag GETSIZ YCL,INITLS Get size of initialization list SPCNVT GETD XPTR,INITLS,YCL Get pointer to list GETSIZ XCL,XPTR Get size of list SPCNV1 GETD ZPTR,XPTR,XCL Get pointer to specifier AEQLC ZPTR,0,,SPCNV2 Skip dummy zero entries RCALL ZPTR,GENVAR,ZPTR Convert specifier to structure PUTD XPTR,XCL,ZPTR Replace pointer to specifier SPCNV2 DECRA XCL,2*DESCR Decrement to next pair ACOMPC XCL,0,SPCNV1 Continue if one remains DECRA YCL,DESCR Decrement to next list ACOMPC YCL,0,SPCNVT Continue if one remains INITD1 GETDC XPTR,INITB,0 Get specifier to convert RCALL YPTR,GENVAR,(XPTR) Convert it to string structure GETDC ZPTR,INITB,DESCR Get location to put it PUTDC ZPTR,0,YPTR Place pointer to string structure INCRA INITB,2*DESCR Decrement to next pair ACOMP INITB,INITE,,,INITD1 * Compare with end * PUTDC ABRTKY,DESCR,ABOPAT Initial value of ABORT PUTDC ARBKY,DESCR,ARBPAT Initial value of ARB PUTDC BALKY,DESCR,BALPAT Initial value of BAL PUTDC FAILKY,DESCR,FALPAT Initial value of FAIL PUTDC FNCEKY,DESCR,FNCPAT Initial value of FENCE PUTDC REMKY,DESCR,REMPAT Initial value of REM PUTDC SUCCKY,DESCR,SUCPAT Initial value of SUCCEED * SETAC VARSYM,0 Set count of variables to zero RCALL NBSPTR,BLOCK,NMOVER Allocate block for value assignment MOVD CMBSCL,SCBSCL Set up pointer for compiler MOVD UNIT,INPUT Set up input unit MOVD OCBSCL,CMBSCL Project base for interpreter SUM OCLIM,CMBSCL,OCALIM Compute end of code block DECRA OCLIM,5*DESCR Leave room for overflow SETAC INICOM,1 SIGNAL COMPLETION E3.10.6 BRANCH XLATRN *_ *---------------------------------------------------------------------* TITLE 'Compilation and Interpreter Invocation' XLATRD AEQLC LISTCL,0,,XLATRN Skip print if list is off STPRNT IOKEY,OUTBLK,LNBFSP Print line image XLATRN STREAD INBFSP,UNIT,XLATRN,COMP5 SETSP TEXTSP,NEXTSP Read card and set up line STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3 * Determine type of card RCALL ,NEWCRD,,(XLATRD,,) Process card type XLATNX RCALL ,CMPILE,,(COMP3,,XLATNX) * Compile statement INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,ENDCL Insert END function AEQLC LISTCL,0,,XLATP Skip print if list is off STPRNT IOKEY,OUTBLK,LNBFSP Print last line image XLATP AEQLC STYPE,EOSTYP,,XLAEND * Finish on end of statement STREAM XSP,TEXTSP,IBLKTB,COMP3,XLAEND * Analyze END card AEQLC STYPE,EOSTYP,,XLAEND * Finish on end of statement AEQLC STYPE,NBTYP,COMP7 Error if break character STREAM XSP,TEXTSP,LBLTB,COMP7,COMP7 * Analyze END label RCALL XPTR,GENVAR,(XSPPTR) * Generate variable for label GETDC OCBSCL,XPTR,ATTRIB Get start for interpreter AEQLC OCBSCL,0,,COMP7 Error if not attribute AEQLC STYPE,EOSTYP,,XLAEND * Finish on end of statement STREAM XSP,TEXTSP,IBLKTB,COMP7,,COMP7 * Analyze remainder of card XLAEND AEQLC ESAICL,0,,XLATSC Were there any compilation errors? OUTPUT OUTPUT,ERRCF Print message of errors BRANCH XLATND *_ XLATSC OUTPUT OUTPUT,SUCCF Print message of no errors XLATND SETAC UNIT,0 Reset input unit SETAC LPTR,0 Reset last label pointer SETAC OCLIM,0 Reset limit on object code ZERBLK COMREG,COMDCT Clear compiler descriptors SUM XCL,CMBSCL,CMOFCL Compute end of object code RCALL ,SPLIT,(XCL) Split of unused part of block SETAC LISTCL,0 Turn off listing switch MSTIME ETMCL Time out compiler SUBTRT TIMECL,ETMCL,TIMECL Compute elapsed time SETAC CNSLCL,1 Permit label redefinition RCALL ,INTERP,,(MAIN1,MAIN1,MAIN1) * Call interpreter *_ *---------------------------------------------------------------------* TITLE 'Support Procedures' * * Augmentation of Pair Lists * AUGATL PROC , Procedure to augment pair lists POP (A1PTR,A2PTR,A3PTR) List, type and value LOCAPT A4PTR,A1PTR,ZEROCL,AUG1 * Look for hole in list PUTDC A4PTR,DESCR,A2PTR Insert type descriptor PUTDC A4PTR,2*DESCR,A3PTR Insert value descriptor MOVD A5PTR,A1PTR Set up return pointer BRANCH A5RTN Return pair list *_ AUG1 GETSIZ A4PTR,A1PTR Get size of present list INCRA A4PTR,2*DESCR Add two more descriptors SETVC A4PTR,B Insert BLOCK data type RCALL A5PTR,BLOCK,A4PTR Allocate new block PUTD A5PTR,A4PTR,A3PTR Insert value descriptor at end DECRA A4PTR,DESCR Decrement PUTD A5PTR,A4PTR,A2PTR Insert type descriptor above AUGMOV DECRA A4PTR,DESCR Adjust size MOVBLK A5PTR,A1PTR,A4PTR Copy old list at top BRANCH A5RTN Return new list *_ *---------------------------------------------------------------------* * * Code Skipping Procedure * CODSKP PROC , Procedure to skip object code POP YCL Restore number of items to skip CODCNT INCRA OCICL,DESCR Increment offset GETD XCL,OCBSCL,OCICL Get object code descriptor TESTF XCL,FNC,,CODFNC Check for function CODECR DECRA YCL,1 Count down ACOMPC YCL,0,CODCNT,RTN1,INTR10 * Check for end *_ CODFNC PUSH YCL Save number to skip SETAV YCL,XCL Get arguments to skip RCALL ,CODSKP,(YCL) Call self recursively POP YCL Restore number to skip BRANCH CODECR Go around again *_ *---------------------------------------------------------------------* * * Data Type Representation * DTREP PROC , Procedure to represent data type POP A2PTR Restore object VEQLC A2PTR,A,,DTARRY Is is ARRAY? VEQLC A2PTR,T,,DTABLE Is it TABLE? VEQLC A2PTR,R,DTREP1 Is it REAL? REALST DPSP,A2PTR Convert REAL to STRING BRANCH DTREPR Join end processing *_ DTARRY GETDC A3PTR,A2PTR,DESCR Get prototype LOCSP ZSP,A3PTR Get specifier GETLG A3PTR,ZSP Get length ACOMPC A3PTR,ARRLEN,DTREP1 Check for excessive length SETLC DTARSP,0 Clear specifier APDSP DTARSP,ARRSP Append ARRAY APDSP DTARSP,LPRNSP Append '(' APDSP DTARSP,QTSP Append quote APDSP DTARSP,ZSP Append prototype APDSP DTARSP,QTSP Append quote DTARTB APDSP DTARSP,RPRNSP Append ')' SETSP DPSP,DTARSP Move specifier BRANCH DTREPR Return *_ DTABLE GETSIZ A3PTR,A2PTR E3.2.3 GETD A1PTR,A2PTR,A3PTR E3.2.3 DECRA A3PTR,DESCR E3.2.3 GETD A2PTR,A2PTR,A3PTR E3.2.3 DTABL1 AEQLC A1PTR,1,,DTABL2 E3.2.3 SUM A3PTR,A3PTR,A2PTR E3.2.3 DECRA A3PTR,2*DESCR E3.2.3 GETD A1PTR,A1PTR,A2PTR E3.2.3 BRANCH DTABL1 E3.2.3 *_ E3.2.3 DTABL2 DECRA A3PTR,DESCR E3.2.3 DECRA A2PTR,2*DESCR E3.2.3 DIVIDE A3PTR,A3PTR,DSCRTW Divide to get item count INTSPC ZSP,A3PTR Convert to string SETLC DTARSP,0 Clear specifier APDSP DTARSP,ASSCSP Append TABLE APDSP DTARSP,LPRNSP Append '(' APDSP DTARSP,ZSP Append size APDSP DTARSP,CMASP Append comma DIVIDE A2PTR,A2PTR,DSCRTW E3.2.3 INTSPC ZSP,A2PTR E3.2.3 APDSP DTARSP,ZSP Append extent BRANCH DTARTB Join common processing *_ DTREP1 MOVV DT1CL,A2PTR Insert data type LOCAPT A3PTR,DTATL,DT1CL,DTREPE * Look for data type name GETDC A3PTR,A3PTR,2*DESCR Get data type name LOCSP DPSP,A3PTR Get specifier DTREPR RRTURN DPSPTR,1 Return pointer to specifier *_ DTREPE SETSP DPSP,EXDTSP Set up EXTERNAL specifier BRANCH DTREPR Return *_ *---------------------------------------------------------------------* * * Location of Function Descriptor * FINDEX PROC , Procedure to get function descriptor POP F1PTR Restore name LOCAPV F2PTR,FNCPL,F1PTR,FATNF * Look for function pair GETDC F2PTR,F2PTR,DESCR Get function descriptor FATBAK RRTURN F2PTR,1 Return *_ FATNF INCRA NEXFCL,2*DESCR Increment function block offset ACOMPC NEXFCL,FBLKSZ,FATBLK * Check for end FATNXT SUM F2PTR,FBLOCK,NEXFCL Compute position RCALL FNCPL,AUGATL,(FNCPL,F2PTR,F1PTR) * Augment function pair list PUTDC F2PTR,0,UNDFCL Insert undefined function PUTDC F2PTR,DESCR,F1PTR Insert name BRANCH FATBAK Join return *_ FATBLK RCALL FBLOCK,BLOCK,FBLKRQ Allocate new function block SETF FBLOCK,FNC Insert function flag SETVC FBLOCK,0 Clear data type SETAC NEXFCL,DESCR Initialize offset BRANCH FATNXT Join processing *_ *---------------------------------------------------------------------* TITLE 'Storage Allocation and Regeneration Procedures' * * Allocation of Block * BLOCK PROC , Procedure to allocate blocks POP ARG1CL Restore size to allocate ACOMP ARG1CL,SIZLMT,SIZERR,SIZERR * Check against size limit BLOCK1 MOVD BLOCL,FRSGPT Position pointer to title MOVV BLOCL,ARG1CL Move data type INCRA FRSGPT,DESCR Leave room for title SUM FRSGPT,FRSGPT,ARG1CL * Move position pointer past end ACOMP TLSGP1,FRSGPT,,,BLOGC * Check for end of region ZERBLK BLOCL,ARG1CL Clear block PUTAC BLOCL,0,BLOCL Set up self-pointer in title SETFI BLOCL,TTL Insert title flag SETSIZ BLOCL,ARG1CL Insert block size RRTURN BLOCL,1 Return pointer to block *_ BLOGC MOVA FRSGPT,BLOCL Restore position pointer RCALL ,GC,(ARG1CL),(ALOC2,BLOCK1) * Regenerate storage *_ *---------------------------------------------------------------------* * * Generation of Natural Variables * GENVAR PROC , Procedure to generate variable SETAC CONVSW,0 Note GENVAR entry POP AXPTR Resotre pointer to specifier GETSPC SPECR1,AXPTR,0 Get specifier LEQLC SPECR1,0,,RT1NUL Avoid null string LOCA1 VARID EQUVCL,SPECR1 Compute bin and ascension numbers SUM BUKPTR,OBPTR,EQUVCL Find bin LOCA2 MOVD LSTPTR,BUKPTR Save working copy GETAC BUKPTR,BUKPTR,LNKFLD * Get link descriptor AEQLC BUKPTR,0,,LOCA5 Check for end of chain VCMPIC BUKPTR,LNKFLD,EQUVCL,LOCA5,,LOCA2 * Compare ascension numbers LOCSP SPECR2,BUKPTR Get specifier to string in storage LEXCMP SPECR1,SPECR2,LOCA2,,LOCA2 * Compare strings MOVD LCPTR,BUKPTR Return string in storage BRANCH LOCRET *_ LOCA5 GETLG AXPTR,SPECR1 Get length of string GETLTH BKLTCL,AXPTR Compute space required ACOMP BKLTCL,SIZLMT,SIZERR * Check against size limit LOCA7 MOVD LCPTR,FRSGPT Point to position in storage SETVC LCPTR,S Set data type to STRING INCRA FRSGPT,DESCR Leave space for title SUM FRSGPT,FRSGPT,BKLTCL * Skip required space ACOMP TLSGP1,FRSGPT,,,LOCA4 * Check for end of region PUTDC LCPTR,0,ZEROCL Clear title PUTAC LCPTR,0,LCPTR Point title to self SETFI LCPTR,TTL+STTL Set string and title flags SETSIZ LCPTR,AXPTR Insert size of string AEQLC CONVSW,0,LOCA6 Check for GENVAR entry PUTDC LCPTR,DESCR,NULVCL Set value to null string PUTDC LCPTR,ATTRIB,ZEROCL Set label attribute to zero LOCSP SPECR2,LCPTR Get specifier to string structure SETLC SPECR2,0 Clear length APDSP SPECR2,SPECR1 Move new string in LOCA6 PUTVC LCPTR,LNKFLD,EQUVCL Insert ascension number PUTAC LCPTR,LNKFLD,BUKPTR Insert link pointer PUTAC LSTPTR,LNKFLD,LCPTR Link to last structure INCRA VARSYM,1 Increment count of new variables LOCRET RRTURN LCPTR,1 Return pointer to structure *_ LOCA4 MOVA FRSGPT,LCPTR Restore position pointer RCALL ,GC,(BKLTCL),(ALOC2,LOCA7) * Regenerate storage *_ *---------------------------------------------------------------------* * * Generation of Variable from Integer * GNVARI PROC GENVAR Procedure to generate string SETAC CONVSW,0 Note GENVAR entry POP AXPTR Restore integer INTSPC SPECR1,AXPTR Convert to string BRANCH LOCA1 Join processing *_ *---------------------------------------------------------------------* * * Allocation of Space for Variable * CONVAR PROC GENVAR Procedure to get space for variable POP AXPTR Restore length AEQLC AXPTR,0,,RT1NUL Avoid null string SETAC CONVSW,1 Note CONVAR entry GETLTH BKLTCL,AXPTR Get space required ACOMP BKLTCL,SIZLMT,SIZERR * Check against size limit SUM TEMPCL,FRSGPT,BKLTCL * Skip required space INCRA TEMPCL,DESCR Save space for title ACOMP TLSGP1,TEMPCL,,,CONVR4 * Check for end of region CONVR5 PUTDC FRSGPT,0,ZEROCL Clear title PUTAC FRSGPT,0,FRSGPT Set up self pointer SETFI FRSGPT,TTL+STTL Set string and title flags SETSIZ FRSGPT,AXPTR Insert tentative size of string PUTDC FRSGPT,DESCR,NULVCL Insert null string as value PUTDC FRSGPT,ATTRIB,ZEROCL * Set label to zero MOVA BKLTCL,FRSGPT E3.3.2 RRTURN BKLTCL,1 E3.3.2 *_ CONVR4 RCALL ,GC,BKLTCL,(ALOC2,CONVR5) * Regenerate storage *_ *---------------------------------------------------------------------* * * Generation of Variable in Place * GNVARS PROC GENVAR Procedure to entry string POP AXPTR Restore length AEQLC AXPTR,0,,RT1NUL Avoid null string LOCSP SPECR1,FRSGPT Get specifier to position PUTLG SPECR1,AXPTR Insert final length SETSIZ FRSGPT,AXPTR Insert size in title BRANCH LOCA1 Join processing *_ *---------------------------------------------------------------------* * * Storage Regeneration * GC PROC , Storage regeneration procedure POP GCREQ Restore space required PSTACK BLOCL Post stack position SUBTRT BLOCL,BLOCL,STKPTR Compute stack length used SETSIZ STKPTR,BLOCL Set stack size MOVD BKDXU,PRMDX Number of resident blocks GCT GETD GCMPTR,PRMPTR,BKDXU Get next resident block AEQLC GCMPTR,0,,GCTDWN Skip nonpointers RCALL ,GCM,(GCMPTR) Scan resident block GCTDWN DECRA BKDXU,DESCR Decrement block count AEQLC BKDXU,0,GCT Test for end of loop SETAC BKPTR,OBLIST-DESCR Set up pointer to bins GCBA1 ACOMP BKPTR,OBEND,GCLAD Check for end of bins INCRA BKPTR,DESCR Increment bin pointer MOVD ST1PTR,BKPTR Get working copy GCBA2 GETAC ST1PTR,ST1PTR,LNKFLD * Get link pointer AEQLC ST1PTR,0,,GCBA1 Test for end of chain TESTFI ST1PTR,MARK,,GCBA2 Test for marked structure GETDC ST2PTR,ST1PTR,DESCR Get value descriptor DEQL ST2PTR,NULVCL,GCBA4 Mark if nonnull AEQLIC ST1PTR,ATTRIB,0,,GCBA2 * Test attribute also GCBA4 PUTDC GCBLK,DESCR,ST1PTR Set up pseudoblock RCALL ,GCM,(GCBLK),GCBA2 Mark string structure *_ GCLAD MOVD CPYCL,HDSGPT Initialize target pointer MOVD TTLCL,HDSGPT Initialize block pointer GCLAD0 BKSIZE BKDX,TTLCL Get size of block TESTFI TTLCL,MARK,GCLAD7 Is the block marked? SUM CPYCL,CPYCL,BKDX Is block marked? SUM TTLCL,TTLCL,BKDX Update block pointer AEQL TTLCL,FRSGPT,GCLAD0,GCBB1 * Check for end of region *_ GCLAD7 MOVD MVSGPT,TTLCL Update compression barrier GCLAD4 SUM TTLCL,TTLCL,BKDX Update block pointer AEQL TTLCL,FRSGPT,,GCBB1 Check for end of region BKSIZE BKDX,TTLCL Get size of block TESTFI TTLCL,MARK,GCLAD4 Is block marked? PUTAC TTLCL,0,CPYCL Point title to target SUM CPYCL,CPYCL,BKDX Update target pointer BRANCH GCLAD4 Continue *_ GCBB1 SETAC BKPTR,OBLIST-DESCR Set up pointer to bins SETAC NODPCL,1 No dump while reorganizing GCBB2 ACOMP BKPTR,OBEND,GCLAP Check for end of bins INCRA BKPTR,DESCR Increment bin pointer MOVD ST1PTR,BKPTR Get work copy GCBB3 MOVD ST2PTR,ST1PTR Save pointer to be linked GCBB4 GETAC ST1PTR,ST1PTR,LNKFLD * Get link pointer AEQLC ST1PTR,0,,GCBB5 Check for end of chain TESTFI ST1PTR,MARK,GCBB4 Is string marked? GETAC BLOCL,ST1PTR,0 Get target address PUTAC ST2PTR,LNKFLD,BLOCL Set link to target BRANCH GCBB3 Continue *_ GCBB5 PUTAC ST2PTR,LNKFLD,ZEROCL * Set last link to zero BRANCH GCBB2 Continue *_ GCLAP MOVD TTLCL,HDSGPT Initialize target pointer GCLAP0 BKSIZE BKDXU,TTLCL Get size of block TESTFI TTLCL,STTL,,GCLAP1 Check for string MOVD BKDX,BKDXU Working copy of block size BRANCH GCLAP2 *_ GCLAP1 SETAC BKDX,3*DESCR Three descriptors for string GCLAP2 TESTFI TTLCL,MARK,GCLAP5 Is block marked? DECRA BKDX,DESCR Decrement offset GCLAP3 GETD DESCL,TTLCL,BKDX Get next descriptor in block TESTF DESCL,PTR,GCLAP4 Is it a pointer? ACOMP DESCL,MVSGPT,,,GCLAP4 * Is it above compression barrier? TOP TOPCL,OFSET,DESCL Compute offset to target ADJUST DESCL,TOPCL,OFSET Adjust pointer to target PUTD TTLCL,BKDX,DESCL Put descriptor back in block GCLAP4 DECRA BKDX,DESCR Decrement offset AEQLC BKDX,0,GCLAP3 Check for end of block GCLAP5 SUM TTLCL,TTLCL,BKDXU Move to next block AEQL TTLCL,FRSGPT,GCLAP0 Check for end of region MOVD BKDXU,PRMDX Number of resident blocks GCLAT1 GETD TTLCL,PRMPTR,BKDXU Get next resident block AEQLC TTLCL,0,,GCLAT4 Skip nonpointer GETSIZ BKDX,TTLCL Get size of block GCLAT2 GETD DESCL,TTLCL,BKDX Get descriptor from block TESTF DESCL,PTR,GCLAT3 Is it a pointer? ACOMP DESCL,MVSGPT,,,GCLAT3 * Is it above compression barrier? TOP TOPCL,OFSET,DESCL Compute offset to target ADJUST DESCL,TOPCL,OFSET Adjust pointer to target PUTD TTLCL,BKDX,DESCL Put descriptor back in block GCLAT3 DECRA BKDX,DESCR Decrement offset AEQLC BKDX,0,GCLAT2 Check for end of block GCLAT4 DECRA BKDXU,DESCR Decrement count of resident blocks AEQLC BKDXU,0,GCLAT1 Check for end of resident blocks MOVD TTLCL,HDSGPT Set up target pointer GCLAM0 BKSIZE BKDXU,TTLCL Get size of block ACOMP TTLCL,MVSGPT,GCLAM5,GCLAM5 * Has compression barrier been reached GETAC TOPCL,TTLCL,0 Get target position MOVDIC TOPCL,0,TTLCL,0 Move title to target position RSETFI TOPCL,MARK Clear mark flag BRANCH GCLAM4 Continue *_ GCLAM5 MOVA BKDX,BKDXU Working copy of block size DECRA BKDX,DESCR Size to be moved TESTFI TTLCL,MARK,GCLAM4 Is block marked? GETAC TOPCL,TTLCL,0 Get target position MOVDIC TOPCL,0,TTLCL,0 Move title RSETFI TOPCL,MARK Clear mark flag MOVBLK TOPCL,TTLCL,BKDX Move block itself GCLAM4 SUM TTLCL,TTLCL,BKDXU Get to next block AEQL TTLCL,FRSGPT,GCLAM0 Check for end of region INCRA GCNO,1 Increment count of regenerations SETAC NODPCL,0 Permit dump BKSIZE BKDX,TOPCL Get size of last block SUM FRSGPT,TOPCL,BKDX Compute new allocation pointer RESETF FRSGPT,FNC Clear possible function flag SUBTRT GCGOT,TLSGP1,FRSGPT Compute amount reclaimed DECRA GCGOT,DESCR RESETF GCGOT,PTR Clear pointer flag ACOMP GCREQ,GCGOT,FAIL Compare with amount required RRTURN GCGOT,2 *_ *---------------------------------------------------------------------* * * Block Marking * GCM PROC , Procedure to mark blocks POP BK1CL Restore block to mark from PUSH ZEROCL Save end marker GCMA1 GETSIZ BKDX,BK1CL Get size of block GCMA2 GETD DESCL,BK1CL,BKDX Get descriptor TESTF DESCL,PTR,GCMA3 Is it a pointer? AEQLC DESCL,0,,GCMA3 Is address zero? TOP TOPCL,OFSET,DESCL Get to title of block pointed to TESTFI TOPCL,MARK,GCMA4 Is block marked? GCMA3 DECRA BKDX,DESCR Decrement offset AEQLC BKDX,0,GCMA2 Check for end of block POP BK1CL Restore block pushed AEQLC BK1CL,0,,RTN1 Check for end SETAV BKDX,BK1CL Get size remaining BRANCH GCMA2 Continue processing *_ GCMA4 DECRA BKDX,DESCR Decrement offset AEQLC BKDX,0,,GCMA9 Check for end SETVA BK1CL,BKDX Insert offset PUSH BK1CL Save current block GCMA9 MOVD BK1CL,TOPCL Set poiner to new block SETFI BK1CL,MARK Mark block TESTFI BK1CL,STTL,GCMA1 Is it a string? MOVD BKDX,TWOCL Set size of string to 2 BRANCH GCMA2 Join processing *_ *---------------------------------------------------------------------* * * Procedure to Split Blocks SPLIT PROC , Procedure to split blocks POP A4PTR Restore pointer to middle of block TOP A5PTR,A6PTR,A4PTR Get title and offset AEQLC A6PTR,0,,RTN1 Avoid block of zero length GETSIZ A7PTR,A5PTR Get present block size SUBTRT A7PTR,A7PTR,A6PTR Subtract offset DECRA A7PTR,DESCR Decrement for title ACOMPC A7PTR,0,,RTN1,RTN1 Avoid block of zero length SETSIZ A5PTR,A6PTR Reset size of old block INCRA A4PTR,DESCR Adjust pointer to middle PUTDC A4PTR,0,ZEROCL PUTAC A4PTR,0,A4PTR SETFI A4PTR,TTL Insert title flag SETSIZ A4PTR,A7PTR Insert size fo new block BRANCH RTN1 Return *_ *---------------------------------------------------------------------* TITLE 'Compilation Procedures' * * Binary Operator Analysis * BINOP PROC , Compiler binary operator analysis RCALL ,FORBLK,,BINOP1 Test for initial blank AEQLC BRTYPE,NBTYP,RTN2 If so, fail on break STREAM XSP,TEXTSP,BIOPTB,BINCON MOVD ZPTR,STYPE Move function descriptor BRANCH RTZPTR Return function descriptor *_ BINOP1 RCALL ,FORWRD,,COMP3 If no blank, find character SELBRA BRTYPE,(,RTN2,RTN2,,,RTN2,RTN2) BINERR SETAC EMSGCL,ILLBIN Set up error message BRANCH RTN1 Take error return *_ BINCON MOVD ZPTR,CONCL No operator, concatenation BRANCH RTZPTR Return function descriptor *_ BINEOS SETAC EMSGCL,ILLEOS Set up error message BRANCH RTN1 Error return *_ *---------------------------------------------------------------------* * * Statement Compilation * CMPILE PROC , Procedure to compile statement SETAC BRTYPE,0 Clear break indicator MOVD BOSCL,CMOFCL Set statement beginning offset INCRA CSTNCL,1 Increment statement number STREAM XSP,TEXTSP,LBLTB,CERR1 * Break out label LEQLC XSP,0,,CMPILA Check for no label INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,BASECL * Insert BASE function SUM CMBSCL,CMBSCL,CMOFCL * Add offset to base ACOMP CMBSCL,OCLIM,,,CMPILO * Check for end of object code RCALL XCL,BLOCK,CODELT Get block for more PUTDC CMBSCL,0,GOTGCL Replace BASE with direct goto PUTDC CMBSCL,DESCR,LIT1CL E3.7.1 PUTDC CMBSCL,2*DESCR,XCL Aim at new block MOVD CMBSCL,XCL Set up base of new region SUM OCLIM,CMBSCL,CODELT Compute end of new block DECRA OCLIM,5*DESCR Leave safety factor PUTDC CMBSCL,DESCR,BASECL Set BASE function in new region INCRA CMBSCL,DESCR Increment base CMPILO SETAC CMOFCL,0 Zero offset SETAC BOSCL,0 Zero base offset RCALL LPTR,GENVAR,XSPPTR Get variable for label AEQLIC LPTR,ATTRIB,0,,CMPILC * Check for previous definition AEQLC CNSLCL,0,,CERR2 Check for label redefinition CMPILC PUTDC LPTR,ATTRIB,CMBSCL Insert label attribute DEQL LPTR,ENDPTR,,RTN2 Check for END CMPILA RCALL ,FORBLK,,CERR12 Get to next character AEQLC BRTYPE,EOSTYP,,RTN3 Was end of statement founc? INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,INITCL * Insert INIT function INCRA CMOFCL,DESCR Increment offset MOVD FRNCL,CMOFCL Save offset for failure position AEQLC BRTYPE,NBTYP,,CMPSUB * Check for nonbreak AEQLC BRTYPE,CLNTYP,CERR3,CMPGO * Check for goto field *_ CMPSUB RCALL SUBJND,ELEMNT,,(CDIAG,COMP3) * Compiler subject RCALL ,FORBLK,,CERR5 Get to next character AEQLC BRTYPE,NBTYP,,CMPATN * Check for nonbreak AEQLC BRTYPE,EQTYP,,CMPFRM * Check for assignment RCALL ,TREPUB,(SUBJND) Copy subject into object code AEQLC BRTYPE,CLNTYP,,CMPGO * Check for goto AEQLC BRTYPE,EOSTYP,CERR5,CMPNGO * Check for end of statement *_ CMPATN RCALL PATND,EXPR,,CDIAG Compile pattern AEQLC BRTYPE,EQTYP,,CMPASP * Check for replacement INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,SCANCL * Insert SCAN function RCALL ,TREPUB,(SUBJND) Copy subject into object code RCALL ,TREPUB,(PATND) Copy pattern into object code CMPTGO AEQLC BRTYPE,EOSTYP,,CMPNGO * Check for end of statement AEQLC BRTYPE,CLNTYP,CERR5,CMPGO * Check for end of statement *_ CMPFRM RCALL FORMND,EXPR,,CDIAG Compile object INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,ASGNCL * Insert ASGN function RCALL ,TREPUB,(SUBJND) Copy subject into object code BRANCH CMPFT Join object publication *_ CMPASP RCALL FORMND,EXPR,,CDIAG Compile object INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,SJSRCL * Insert SJSR function RCALL ,TREPUB,(SUBJND) Copy subject into object code RCALL ,TREPUB,(PATND) Copy pattern into object code CMPFT RCALL ,TREPUB,FORMND,CMPTGO * Copy object into object code *_ CMPNGO SETVA CSTNCL,CMOFCL Set up offset for failure PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT BRANCH RTN3 Statement compilation is done *_ Get to next character CMPGO RCALL ,FORWRD,,COMP3 Check for end of statement AEQLC BRTYPE,EOSTYP,,CMPNGO * Check for nonbreak AEQLC BRTYPE,NBTYP,CERR11 STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12 * Analyze goto field MOVD GOGOCL,GOTLCL Predict GOTL SETAC GOBRCL,RPTYP Set up predicted closing break ACOMP STYPE,GTOCL,,CMPGG,CMPGG * Check for direct goto MOVD GOGOCL,GOTGCL Set up direct goto SETAC GOBRCL,RBTYP Set up closing break CMPGG SELBRA STYPE,(,CMPSGO,CMPFGO,,CMPSGO,CMPFGO) * Branch on type CMPUGO SETVA CSTNCL,CMOFCL Set up offset for failure PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT RCALL GOTOND,EXPR,,CDIAG Compile goto AEQL BRTYPE,GOBRCL,CERR11 * Verify closing break INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,GOGOCL * Insert goto function RCALL ,TREPUB,(GOTOND) Copy goto into object code RCALL ,FORWRD,,COMP3 Get to next character AEQLC BRTYPE,EOSTYP,CERR11,RTN3 * Check for end of statement *_ CMPSGO RCALL SGOND,EXPR,,CDIAG Compile success goto AEQL BRTYPE,GOBRCL,CERR11 * Verify break character INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,GOGOCL * Insert goto function RCALL ,TREPUB,(SGOND) Copy goto into object code RCALL ,FORWRD,,COMP3 Get to next character AEQLC BRTYPE,EOSTYP,CMPILL * Check for end of statement SETVA CSTNCL,CMOFCL Set up offset for failure PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT BRANCH RTN3 Compilation is complete, return *_ CMPILL AEQLC BRTYPE,NBTYP,CERR11 Check for nonbreak STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12 * Analyze goto field AEQLC STYPE,FGOTYP,CMPFTC Check for failure goto MOVD GOGOCL,GOTLCL Set up goto SETAC GOBRCL,RPTYP Set up closing break BRANCH CMPUGO Join processing *_ CMPFTC AEQLC STYPE,FTOTYP,CERR11 Verify failure goto MOVD GOGOCL,GOTGCL Set up goto SETAC GOBRCL,RBTYP Set up closing break BRANCH CMPUGO Join processing *_ CMPFGO RCALL FGOND,EXPR,,CDIAG Compile failure goto AEQL BRTYPE,GOBRCL,CERR11 * Verify failure goto RCALL ,FORWRD,,COMP3 Get to next character AEQLC BRTYPE,EOSTYP,CMPILM * Check for end of statement INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,GOTOCL * Insert goto function INCRA CMOFCL,DESCR Increment offset MOVD SRNCL,CMOFCL Save location for success SETVA CSTNCL,CMOFCL Set up failure offset PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,GOGOCL * Insert goto function RCALL ,TREPUB,(FGOND) Copy goto into object code PUTD CMBSCL,SRNCL,CMOFCL Insert success offset into code BRANCH RTN3 Compilation is complete, return *_ CMPILM AEQLC BRTYPE,NBTYP,CERR11 Verify nonbreak STREAM XSP,TEXTSP,GOTOTB,CERR11,CERR12 * Analyze goto field AEQLC STYPE,SGOTYP,CMPSTC Check for success goto PUSH GOTLCL Save goto type SETAC GOBRCL,RPTYP Set up closing break BRANCH CMPILN Join processing *_ CMPSTC AEQLC STYPE,STOTYP,CERR11 Verify success goto PUSH GOTGCL Save goto type SETAC GOBRCL,RBTYP Set up closing break CMPILN RCALL SGOND,EXPR,,CDIAG Compile success goto AEQL BRTYPE,GOBRCL,CERR11 * Verify closing break RCALL ,FORWRD,,COMP3 Get to next character AEQLC BRTYPE,EOSTYP,CERR11 * Verify end of statement INCRA CMOFCL,DESCR Increment offset POP WCL Restore goto type PUTD CMBSCL,CMOFCL,WCL Insert goto function RCALL ,TREPUB,(SGOND) Copy goto into object code SETVA CSTNCL,CMOFCL Set up failure offset PUTD CMBSCL,FRNCL,CSTNCL Insert argument of INIT INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,GOGOCL * Insert goto function RCALL ,TREPUB,(FGOND),RTN3 * Copy goto into object code *_ CERR1 SETAC EMSGCL,EMSG1 Erroneous label BRANCH CDIAG *_ CERR2 SETAC EMSGCL,EMSG2 Multidefined label BRANCH CDIAG *_ CERR3 SETAC EMSGCL,EMSG3 Break character before subject BRANCH CDIAG *_ CERR5 SETAC EMSGCL,ILLBRK Illegal character after pattern BRANCH CDIAG *_ CERR12 SETAC EMSGCL,ILLEOS Illegal statement termination BRANCH CDIAG *_ CERR11 SETAC EMSGCL,EMSG14 Characters after goto CDIAG INCRA BOSCL,DESCR Increment offset of beginning PUTD CMBSCL,BOSCL,ERORCL Insert ERROR function INCRA BOSCL,DESCR Increment offset PUTD CMBSCL,BOSCL,CSTNCL Insert argument of ERROR MOVD CMOFCL,BOSCL Reposition offset INCRA ESAICL,DESCR Increment count of errors ACOMP ESAICL,ESALIM,COMP9 Test for excessive errors AEQLC LISTCL,0,,CDIAG1 Check for listing mode MOVD YCL,ERRBAS Set up length of error vector AEQLC BRTYPE,EOSTYP,,CDIAG3 * Check for end of statement GETLG XCL,TEXTSP Get length remaining SUBTRT YCL,YCL,XCL Compute position for marker CDIAG3 PUTLG ERRSP,YCL Insert length APDSP ERRSP,QTSP Set in marker AEQLC BRTYPE,EOSTYP,,CDIAG2 * Check for end of statement STPRNT IOKEY,OUTBLK,LNBFSP Print statement CDIAG2 STPRNT IOKEY,OUTBLK,ERRSP Print error marker PUTLG ERRSP,YCL Insert length in marker APDSP ERRSP,BLSP Blank out marker GETSPC TSP,EMSGCL,0 Get error message SETLC CERRSP,0 Clear specifier APDSP CERRSP,STARSP Append attention getter APDSP CERRSP,TSP Append error message STPRNT IOKEY,OUTBLK,CERRSP Print error message STPRNT IOKEY,OUTBLK,BLSP Print blank line CDIAG1 AEQLC UNIT,0,,RTN1 E3.0.1 AEQLC BRTYPE,EOSTYP,,RTN3 E3.0.1 STREAM XSP,TEXTSP,EOSTB,COMP3,,RTN3 * Get to end of statement DIAGRN STREAD INBFSP,UNIT,DIAGRN,COMP5 * Read card image SETSP TEXTSP,NEXTSP Set up new line STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3 * Analyze card type RCALL ,NEWCRD,,(,,RTN3) Process card image AEQLC LISTCL,0,,DIAGRN STPRNT IOKEY,OUTBLK,LNBFSP Print out bypassed card BRANCH DIAGRN *_ *---------------------------------------------------------------------* * * Element Analysis * ELEMNT PROC , Element analysis procedure RCALL ELEMND,UNOP,,RTN2 Get tree of unary operators STREAM XSP,TEXTSP,ELEMTB,ELEICH,ELEILI * Break out element ELEMN9 SELBRA STYPE,(,ELEILT,ELEVBL,ELENST,ELEFNC,ELEFLT,ELEARY) * Branch on element type FSHRTN XSP,1 Delete initial quote SHORTN XSP,1 Remove terminal quote RCALL XPTR,GENVAR,(XSPPTR) * Generate variable for literal ELEMN5 RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node PUTDC ELEXND,CODE,LITCL Insert literal function RCALL ELEYND,BLOCK,CNDSIZ Allocate block for tree node PUTDC ELEYND,CODE,XPTR Insert literal value ADDSON ELEXND,ELEYND Add node as son ELEMN1 AEQLC ELEMND,0,ELEMN6 Check for empty tree MOVD ZPTR,ELEXND Set up return BRANCH ELEMRR Join return processing *_ ELEMN6 ADDSON ELEMND,ELEXND Add as son of present tree ELEMNR MOVD ZPTR,ELEMND Move tree to return ELEMRR AEQLIC ZPTR,FATHER,0,,RTZPTR * Is pointer at top of tree? GETDC ZPTR,ZPTR,FATHER Move back to father BRANCH ELEMRR Continue up tree *_ ELEILT SPCINT XPTR,XSP,ELEINT,ELEMN5 * Convert string to integer *_ ELEFLT SPREAL XPTR,XSP,ELEDEC,ELEMN5 * Convert string to real *_ ELEVBL RCALL XPTR,GENVAR,(XSPPTR) * Generate variable RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node PUTDC ELEXND,CODE,XPTR Insert name BRANCH ELEMN1 Join exit processing *_ ELENST PUSH ELEMND Save current tree RCALL ELEXND,EXPR,,RTN1 Evaluate nested expression POP ELEMND Restore tree AEQLC BRTYPE,RPTYP,ELECMA,ELEMN1 * Verify right parenthesis *_ ELEFNC SHORTN XSP,1 Delete open parenthesis RCALL XPTR,GENVAR,(XSPPTR) * Generate variable for function name RCALL XCL,FINDEX,(XPTR) Find function descriptor RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node PUTDC ELEXND,CODE,XCL Insert function descriptor in node AEQLC ELEMND,0,,ELEMN7 Is tree empty? ADDSON ELEMND,ELEXND Add node as son to tree ELEMN7 PUSH ELEXND Save current node RCALL ELEXND,EXPR,,RTN1 Evaluate argument of function POP ELEMND Resotre current node ADDSON ELEMND,ELEXND Add argument as son MOVD ELEMND,ELEXND Move to new node ELEMN2 AEQLC BRTYPE,RPTYP,,ELEMN3 * Check for left parenthesis AEQLC BRTYPE,CMATYP,ELECMA * Verify comma PUSH ELEMND Save current node RCALL ELEXND,EXPR,,RTN1 Evaluate next argument POP ELEMND Restore current node ADDSIB ELEMND,ELEXND Add argument as sibling MOVD ELEMND,ELEXND Move to new node BRANCH ELEMN2 Continue *_ ELEMN3 GETDC ELEXND,ELEMND,FATHER * Get father of current node GETDC XCL,ELEXND,CODE Get function descriptor GETDC YCL,XCL,0 Get procedure descriptor TESTF YCL,FNC,,ELEMNR Check for fixed number requirement SETAV XCL,XCL Get number of arguments given SETAV YCL,YCL Get number of arguments expected ELEMN4 ACOMP XCL,YCL,ELEMNR,ELEMNR * Compare given and expected RCALL ELEYND,BLOCK,CNDSIZ Allocate block for tree node PUTDC ELEYND,CODE,LITCL Insert literal function RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node PUTDC ELEXND,CODE,NULVCL Insert null string value ADDSON ELEYND,ELEXND Add null as son of literal ADDSIB ELEMND,ELEYND Add literal as extra argument MOVD ELEMND,ELEYND Move to new node INCRA XCL,1 Increment argument count BRANCH ELEMN4 Continue *_ ELEARY SHORTN XSP,1 Remove left bracket RCALL XPTR,GENVAR,(XSPPTR) * Generate variable for array or table RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node PUTDC ELEXND,CODE,ITEMCL Insert ITEM function AEQLC ELEMND,0,,ELEMN8 Is tree empty? ADDSON ELEMND,ELEXND Add as son to tree ELEMN8 MOVD ELEMND,ELEXND Move to new node RCALL ELEXND,BLOCK,CNDSIZ Allocate block for tree node PUTDC ELEXND,CODE,XPTR Insert array or table name ADDSON ELEMND,ELEXND Add as son to tree MOVD ELEMND,ELEXND Move to new node ELEAR1 PUSH ELEMND Save current node RCALL ELEXND,EXPR,,RTN1 Evaluate argument POP ELEMND Restore current node ADDSIB ELEMND,ELEXND Add as sibling to tree MOVD ELEMND,ELEXND Move to new node AEQLC BRTYPE,RBTYP,,ELEMNR * Check for right bracket AEQLC BRTYPE,CMATYP,ELECMA,ELEAR1 * Verify comma *_ ELEICH SETAC EMSGCL,ILCHAR 'ILLEGAL CHARACTER IN ELEMENT' BRANCH RTN1 Error return *_ ELEILI AEQLC STYPE,QLITYP,ELEMN9 Check cause of run out SETAC EMSGCL,OPNLIT 'UNCLOSED LITERAL' BRANCH RTN1 Error return *_ ELEINT SETAC EMSGCL,ILLINT 'ILLEGAL INTEGER' BRANCH RTN1 Error return *_ ELEDEC SETAC EMSGCL,ILLDEC 'ILLEGAL REAL' BRANCH RTN1 Error return *_ ELECMA SETAC EMSGCL,ILLBRK 'ILLEGAL BREAK CHARACTER' BRANCH RTN1 Error return *_ *---------------------------------------------------------------------* * * Expression Analysis * EXPR PROC , Procedure to compile expression RCALL EXELND,ELEMNT,,(RTN1,EXPNUL) * Compile element SETAC EXPRND,0 Zero expression tree BRANCH EXPR2 Join main processing *_ EXPR1 PUSH EXPRND Save expression tree RCALL EXELND,ELEMNT,,(RTN1,EXPERR) * Compile element POP EXPRND Restore expression tree EXPR2 RCALL EXOPCL,BINOP,,(RTN1,EXPR7) * Get binary operator RCALL EXOPND,BLOCK,CNDSIZ Allocate block for tree node PUTDC EXOPND,CODE,EXOPCL Insert binary operator AEQLC EXPRND,0,EXPR3 Check for empty tree ADDSON EXOPND,EXELND Add node as son MOVD EXPRND,EXELND Move to new node BRANCH EXPR1 Continue processing *_ EXPR3 GETDC EXOPCL,EXOPCL,2*DESCR * Get precedence descriptor SETAV EXOPCL,EXOPCL Get left precedence GETDC EXEXND,EXPRND,FATHER * Get father of node GETDC XPTR,EXEXND,CODE Get function descriptor GETDC XPTR,XPTR,2*DESCR Get precedence descriptor ACOMP XPTR,EXOPCL,EXPR4 Compare precedences ADDSIB EXPRND,EXOPND Add node as sibling MOVD EXPRND,EXOPND Move to new node ADDSON EXPRND,EXELND Put current node as son MOVD EXPRND,EXELND Move to new node BRANCH EXPR1 Continue processing *_ EXPR4 ADDSIB EXPRND,EXELND Add current node as sibling EXPR5 AEQLIC EXPRND,FATHER,0,,EXPR11 * Check for root node GETDC EXPRND,EXPRND,FATHER * Get father node AEQLIC EXPRND,FATHER,0,,EXPR11 * Check for root node GETDC EXEXND,EXPRND,FATHER * Get father node GETDC XPTR,EXEXND,CODE Get function descriptor GETDC XPTR,XPTR,2*DESCR Get precedence descriptor ACOMP XPTR,EXOPCL,EXPR5 Compare precedences INSERT EXPRND,EXOPND Insert node above BRANCH EXPR1 Continue processing *_ EXPR7 AEQLC EXPRND,0,EXPR10 Check for empty tree MOVD XPTR,EXELND Set up for return BRANCH EXPR9 Join end processing *_ EXPR10 ADDSIB EXPRND,EXELND Add node as sibling MOVD XPTR,EXPRND Set up for return EXPR9 AEQLIC XPTR,FATHER,0,,RTXNAM * Check for root node GETDC XPTR,XPTR,FATHER Go back to father BRANCH EXPR9 Continue up tree *_ EXPR11 ADDSON EXOPND,EXPRND Add node as son BRANCH EXPR1 Continue processing *_ EXPNUL RCALL EXPRND,BLOCK,CNDSIZ Allocate block for tree node PUTDC EXPRND,CODE,LITCL Insert literal function RCALL EXEXND,BLOCK,CNDSIZ Allocate block for tree node PUTDC EXEXND,CODE,NULVCL Insert null string as value ADDSON EXPRND,EXEXND Add node as son MOVD XPTR,EXPRND Set up for return BRANCH RTXNAM *_ EXPERR SETAC EMSGCL,ILLEOS 'ILLEGAL END OF STATEMENT' BRANCH RTN1 Take error return *_ *---------------------------------------------------------------------* * * Location of Next Nonblank Character * FORWRD PROC , Procedure to get to next character STREAM XSP,TEXTSP,FRWDTB,COMP3,FORRUN * Break for next nonblank FORJRN MOVD BRTYPE,STYPE Set up break type BRANCH RTN2 Return *_ FORRUN AEQLC UNIT,0,,FOREOS Check for input stream AEQLC LISTCL,0,,FORRUR Check listing switch STPRNT IOKEY,OUTBLK,LNBFSP Print card image FORRUR STREAD INBFSP,UNIT,FORRUR,COMP5 * Read new card iamge SETSP TEXTSP,NEXTSP Set up new line STREAM XSP,TEXTSP,CARDTB,COMP3,COMP3 * Determine card type RCALL ,NEWCRD,,(FORRUN,FORWRD) * Process new card FOREOS MOVD BRTYPE,EOSCL Set up end-of-card BRANCH RTN2 Return *_ FORBLK PROC FORWRD Procedure to get to nonblank STREAM XSP,TEXTSP,IBLKTB,RTN1,FORRUN,FORJRN * Break out nonblank from blank *_ *---------------------------------------------------------------------* * * Card Image Processing * NEWCRD PROC , Process new card image SELBRA STYPE,(,CMTCRD,CTLCRD,CNTCRD) * Branch on card type AEQLC LISTCL,0,,RTN3 Return if listing is off MOVD XCL,CSTNCL Copy of statement number INCRA XCL,1 Increment number INTSPC TSP,XCL Convert it to STRING AEQLC LLIST,0,CARDL Check for left listing SETLC RNOSP,0 Clear right specifier APDSP RNOSP,TSP Set to statement number BRANCH RTN3 *_ CARDL SETLC LNOSP,0 Clear left specifier APDSP LNOSP,TSP Set to statement number BRANCH RTN3 *_ CMTCRD AEQLC LISTCL,0,,RTN1 Return if listing is off CMTCLR SETLC LNOSP,0 Clear left specifier SETLC RNOSP,0 Clear right specifier APDSP LNOSP,BLNSP Blank left specifier APDSP RNOSP,BLNSP Blank right specifier BRANCH RTN1 *_ CNTCRD FSHRTN TEXTSP,1 Remove continue character AEQLC LISTCL,0,,RTN2 Return if listing is off INTSPC TSP,CSTNCL Get specifier for number AEQLC LLIST,0,CARDLL Check for left listing SETLC RNOSP,0 Clear right specifier APDSP RNOSP,TSP Set to statement number BRANCH RTN2 *_ CARDLL SETLC LNOSP,0 Clear left specifier APDSP LNOSP,TSP Set to statement number BRANCH RTN2 *_ CTLCRD FSHRTN TEXTSP,1 Delete control character STREAM XSP,TEXTSP,FRWDTB,COMP3,CMTCRD * Get to next nonblank character AEQLC STYPE,NBTYP,CMTCRD Verify nonbreak STREAM XSP,TEXTSP,LBLXTB,CMTCLR,CMTCLR * Break out command LEXCMP XSP,UNLSP,CTLCR1,,CTLCR1 * Is it UNLIST? SETAC LISTCL,0 Zero listing switch BRANCH RTN1 Return *_ CTLCR1 LEXCMP XSP,LISTSP,CTLCR3,,CTLCR3 * Is it LIST? SETAC LISTCL,1 Turn on listing STREAM XSP,TEXTSP,FRWDTB,COMP3,CMTCLR * Get to next nonblank character AEQLC STYPE,NBTYP,CMTCLR Verify nonbreak STREAM XSP,TEXTSP,LBLXTB,CMTCLR,CMTCLR * Get type of listing LEXCMP XSP,LEFTSP,CTLCR2,,CTLCR2 * Is it LEFT? SETAC LLIST,1 Set left listing switch BRANCH CMTCLR Join terminal processing *_ CTLCR2 SETAC LLIST,0 Zero left listing as default BRANCH CMTCLR Join terminal processing *_ CTLCR3 LEXCMP XSP,EJCTSP,CMTCLR,,CMTCLR * Is it EJECT? AEQLC LISTCL,0,,CMTCLR Skip eject if not listing OUTPUT OUTPUT,EJECTF Eject page BRANCH CMTCLR Join terminal processing *_ *---------------------------------------------------------------------* * * Publication of Code Trees * TREPUB PROC , Publish code tree POP YPTR Restore root node TREPU1 GETDC XPTR,YPTR,CODE Get code descriptor INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,XPTR Insert code descriptor SUM ZPTR,CMBSCL,CMOFCL Compute total position ACOMP ZPTR,OCLIM,TREPU5 Check against limit TREPU4 AEQLIC YPTR,LSON,0,,TREPU2 Is there a left son? GETDC YPTR,YPTR,LSON Get left son BRANCH TREPU1 Continue *_ TREPU2 AEQLIC YPTR,RSIB,0,,TREPU3 Is there a right sibling? GETDC YPTR,YPTR,RSIB Get right sibling BRANCH TREPU1 Continue *_ TREPU3 AEQLIC YPTR,FATHER,0,,RTN1 Is there a father? GETDC YPTR,YPTR,FATHER Get father BRANCH TREPU2 Continue *_ TREPU5 SUM ZPTR,CMOFCL,CODELT Compute additional to get SETVC ZPTR,C Insert CODE data type RCALL XCL,BLOCK,ZPTR Allocate new code block AEQLC LPTR,0,,TREPU6 Is there a last label? PUTDC LPTR,ATTRIB,XCL Insert new code position TREPU6 MOVBLK XCL,CMBSCL,CMOFCL Move old code PUTDC CMBSCL,DESCR,GOTGCL Insert direct goto PUTDC CMBSCL,2*DESCR,LIT1CL E3.7.1 * Insert literal function PUTDC CMBSCL,3*DESCR,XCL Insert pointer to new code INCRA CMBSCL,3*DESCR Update end pointer RCALL ,SPLIT,(CMBSCL) Split off old portion MOVD CMBSCL,XCL Set up new compiler base pointer SUM OCLIM,CMBSCL,ZPTR Compute new limit DECRA OCLIM,5*DESCR Leave safety factor BRANCH TREPU4 Rejoin processing *_ *---------------------------------------------------------------------* * * Unary Operator Analysis * UNOP PROC , Unary operator analysis RCALL ,FORWRD,,COMP3 Get to next nonblank character SETAC XPTR,0 Zero code tree AEQLC BRTYPE,NBTYP,RTN1 Verify nonbreak UNOPA STREAM XSP,TEXTSP,UNOPTB,RTXNAM,RTN1 E3.4.3 * Break out unary operator RCALL YPTR,BLOCK,CNDSIZ Allocate block for tree node PUTDC YPTR,CODE,STYPE Insert function descriptor AEQLC XPTR,0,,UNOPB Is tree empty ADDSON XPTR,YPTR Add new node as son UNOPB MOVD XPTR,YPTR Move to new node BRANCH UNOPA Continue *_ *---------------------------------------------------------------------* TITLE 'Interpreter Executive and Control Procedures' * * Code Basing * BASE PROC , Interpreter code basing procedure SUM OCBSCL,OCBSCL,OCICL Add offset to base SETAC OCICL,0 Zero offset BRANCH RTNUL3 *_ *---------------------------------------------------------------------* * * Direct Goto * GOTG PROC , :<X> RCALL OCBSCL,ARGVAL,,INTR5 * Get code pointer VEQLC OCBSCL,C,INTR4 Must have CODE data type SETAC OCICL,0 Zero offset BRANCH RTNUL3 *_ *---------------------------------------------------------------------* * * Label Goto * GOTL PROC , :(X) INCRA OCICL,DESCR Increment offset GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,GOTLC Test for function GOTLV ACOMPC TRAPCL,0,,GOTLV1,GOTLV1 * Check &TRACE LOCAPT ATPTR,TLABL,XPTR,GOTLV1 * Look for LABEL trace PUSH XPTR Save variable RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace POP XPTR Restore variable GOTLV1 DEQL XPTR,RETCL,GOTL1 Compare with RETURN RRTURN ,6 Return by value *_ GOTL1 DEQL XPTR,FRETCL,GOTL2 Compare with FRETURN RRTURN ,4 Fail *_ GOTL2 DEQL XPTR,NRETCL,GOTL3 Compare with NRETURN RRTURN ,5 Return by name *_ GOTL3 GETDC OCBSCL,XPTR,ATTRIB Get object code base AEQLC OCBSCL,0,,INTR4 Must not be zero SETAC OCICL,0 Zero offset BRANCH RTNUL3 Return *_ GOTLC RCALL XPTR,INVOKE,XPTR,(INTR5,,INTR4) E3.10.3 * Evaluate goto VEQLC XPTR,S,INTR4,GOTLV Variable must be STRING *_ *---------------------------------------------------------------------* * * Internal Goto * GOTO PROC , Interpreter goto procedure INCRA OCICL,DESCR Increment offset GETD OCICL,OCBSCL,OCICL Get offset BRANCH RTNUL3 Return *_ *---------------------------------------------------------------------* * * Statement Initialization * INIT PROC , Statement initialization procedure MOVD LSTNCL,STNOCL Update &LASTNO INCRA OCICL,DESCR Increment offset GETD XCL,OCBSCL,OCICL Get statement data MOVA STNOCL,XCL Update &STNO SETAV FRTNCL,XCL Set up failure offset ACOMP EXNOCL,EXLMCL,EXEX,EXEX * Check &STLIMIT INCRA EXNOCL,1 Increment &STCOUNT ACOMPC TRAPCL,0,,RTNUL3,RTNUL3 * Check &TRACE LOCAPT ATPTR,TKEYL,STCTKY,RTNUL3 RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace BRANCH RTNUL3 *_ *---------------------------------------------------------------------* * * Basic Interpreter Procedure * INTERP PROC , Interpreter core procedure INCRA OCICL,DESCR Increment offset GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,INTERP Test for function RCALL XPTR,INVOKE,(XPTR),(,INTERP,INTERP,RTN1,RTN2,RTN3) MOVD OCICL,FRTNCL Set offset for failure INCRA FALCL,1 Increment &STFCOUNT ACOMPC TRAPCL,0,,INTERP,INTERP * Check &TRACE LOCAPT ATPTR,TKEYL,FALKY,INTERP RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace BRANCH INTERP *_ *---------------------------------------------------------------------* * * Procedure Invocation * INVOKE PROC , Invokation procedure POP INCL Get function index GETDC XPTR,INCL,0 Get procedure descriptor VEQL INCL,XPTR,INVK2 Check argument counts INVK1 BRANIC INCL,0 If equal, branch indirect *_ INVK2 TESTF XPTR,FNC,ARGNER,INVK1 * Check for variable argument number *_ *---------------------------------------------------------------------* TITLE 'Argument Evaluation Procedures' * * Argument Evaluation * ARGVAL PROC , Procedure to evaluate argument INCRA OCICL,DESCR Increment interpreter offset GETD XPTR,OCBSCL,OCICL Get argument TESTF XPTR,FNC,,ARGVC Test for function descriptor ARGV1 AEQLC INSW,0,,ARGV2 Check &INPUT LOCAPV ZPTR,INATL,XPTR,ARGV2 * Look for input association GETDC ZPTR,ZPTR,DESCR Get input descriptor RCALL XPTR,PUTIN,(ZPTR,XPTR),(FAIL,RTXNAM) *_ ARGVC RCALL XPTR,INVOKE,(XPTR),(FAIL,ARGV1,RTXNAM) *_ ARGV2 GETDC XPTR,XPTR,DESCR Get value from name BRANCH RTXNAM *_ *---------------------------------------------------------------------* * * Evaluation of Unevaluated Expressions * EXPVAL PROC , Procedure to evaluate expression SETAC SCL,1 Note procedure entrance EXPVJN POP XPTR Restore pointer to object code EXPVJ2 PUSH (OCBSCL,OCICL,PATBCL,PATICL,WPTR,XCL,YCL,TCL) PUSH (MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL) * Save system state descriptors SPUSH (HEADSP,TSP,TXSP,XSP) * Save system state specifiers MOVD OCBSCL,XPTR Set up new code base SETAC OCICL,DESCR Initialize offset MOVD PDLHED,PDLPTR Set up new history list header MOVD NHEDCL,NAMICL Set up new name list header GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,EXPVC Check for function EXPV11 AEQLC SCL,0,,EXPV6 Check procedure entry AEQLC INSW,0,,EXPV4 Check &INPUT LOCAPV ZPTR,INATL,XPTR,EXPV4 * Look for input association GETDC ZPTR,ZPTR,DESCR Get input association RCALL XPTR,PUTIN,(ZPTR,XPTR),(EXPV1,EXPV6) * Perform input *_ EXPV4 GETDC XPTR,XPTR,DESCR Get value EXPV6 SETAC SCL,2 Set up exit BRANCH EXPV7 Join processing *_ EXPV9 POP SCL Popoff switch EXPV1 SETAC SCL,1 Set new exit switch EXPV7 SPOP (XSP,TXSP,TSP,HEADSP) * Restore system specifiers POP (NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN) POP (TCL,YCL,XCL,WPTR,PATICL,PATBCL,OCICL,OCBSCL) * Restore system descriptors SELBRA SCL,(FAIL,RTXNAM,RTZPTR) * Select exit *_ EXPVC PUSH SCL Save entrance indicator RCALL XPTR,INVOKE,XPTR,(EXPV9,EXPV5,) * Evaluate function POP SCL Restore entrance indicator AEQLC SCL,0,EXPV6 Check entry indicator SETAC SCL,3 Set exit switch MOVD ZPTR,XPTR Set up value BRANCH EXPV7 Join end processing *_ EXPV5 POP SCL Restore entry indicator BRANCH EXPV11 Join processing with name *_ EXPEVL PROC EXPVAL Procedure to get expression value SETAC SCL,0 Set entry indicator BRANCH EXPVJN Join processing *_ EVAL PROC EXPVAL EVAL(X) RCALL XPTR,ARGVAL,,FAIL Get argument VEQLC XPTR,E,,EVAL1 Is it EXPRESSION? VEQLC XPTR,I,,RTXPTR INTEGER is idempotent VEQLC XPTR,R,,RTXPTR REAL is idempotent VEQLC XPTR,S,INTR1 Is it STRING? LOCSP XSP,XPTR Get specifier LEQLC XSP,0,,RTXPTR E3.1.4 SPCINT XPTR,XSP,,RTXPTR Convert to INTEGER SPREAL XPTR,XSP,,RTXPTR Convert to REAL MOVD ZPTR,XPTR Set up to convert to EXPRESSION RCALL XPTR,CONVE,,(FAIL,INTR10) * Convert to EXPRESSION EVAL1 SETAC SCL,0 Set up entry indicator BRANCH EXPVJ2 Join processing *_ *---------------------------------------------------------------------* * * Evaluation of Integer Argument * INTVAL PROC , Integer argument procedure INCRA OCICL,DESCR Increment offset GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,INTVC Check for function INTV1 AEQLC INSW,0,,INTV3 Check &INPUT LOCAPV ZPTR,INATL,XPTR,INTV3 * Look for input association GETDC ZPTR,ZPTR,DESCR Get association RCALL XPTR,PUTIN,(ZPTR,XPTR),FAIL * Perform input INTV LOCSP XSP,XPTR Get specifier for string SPCINT XPTR,XSP,INTR1,RTXNAM * Convert to integer *_ INTV3 GETDC XPTR,XPTR,DESCR Get value INTV2 VEQLC XPTR,I,,RTXNAM INTEGER desired VEQLC XPTR,S,INTR1,INTV STRING must be converted *_ INTVC RCALL XPTR,INVOKE,(XPTR),(FAIL,INTV1,INTV2) *_ *---------------------------------------------------------------------* * * Evaluation of Argument as Pattern * PATVAL PROC , Evaluate argument as pattern INCRA OCICL,DESCR Increment offset GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,PATVC Check for function descriptor PATV1 AEQLC INSW,0,,PATV2 Check &INPUT LOCAPV ZPTR,INATL,XPTR,PATV2 * Look for input association GETDC ZPTR,ZPTR,DESCR Get association RCALL XPTR,PUTIN,(ZPTR,XPTR),(FAIL,RTXNAM) * Perform input *_ PATVC RCALL XPTR,INVOKE,(XPTR),(FAIL,PATV1,PATV3) * Evaluate argument *_ PATV2 GETDC XPTR,XPTR,DESCR Get value PATV3 VEQLC XPTR,P,,RTXNAM Is it PATTERN? VEQLC XPTR,S,,RTXNAM Is it STRING? VEQLC XPTR,I,,GENVIX Is it INTEGER? VEQLC XPTR,R,,PATVR Is it REAL? VEQLC XPTR,E,INTR1 Is it EXPRESSION? RCALL TPTR,BLOCK,STARSZ Allocate block for pattern MOVBLK TPTR,STRPAT,STARSZ Copy pattern for expression PUTDC TPTR,4*DESCR,XPTR Insert expression MOVD XPTR,TPTR Set up value BRANCH RTXNAM Return *_ PATVR REALST XSP,XPTR Convert REAL to STRING RCALL XPTR,GENVAR,XSPPTR,RTXNAM * Generate variable *_ *---------------------------------------------------------------------* * * Evaluation of Argument as String * VARVAL PROC , Evaluate argument as string INCRA OCICL,DESCR Increment offset GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,VARVC Check for function VARV1 AEQLC INSW,0,,VARV4 Check &INPUT LOCAPV ZPTR,INATL,XPTR,VARV4 * Look for input association GETDC ZPTR,ZPTR,DESCR Get input association RCALL XPTR,PUTIN,(ZPTR,XPTR),(FAIL,RTXNAM) * Perform input *_ VARV4 GETDC XPTR,XPTR,DESCR Get value VARV2 VEQLC XPTR,S,,RTXNAM Is it STRING? VEQLC XPTR,I,INTR1,GENVIX Convert INTEGER to STRING *_ VARVC RCALL XPTR,INVOKE,(XPTR),(FAIL,VARV1,VARV2) * Evaluate function *_ *---------------------------------------------------------------------* * * Evaluation of Argument Pair * XYARGS PROC , Procedure to evaluate argument pair SETAC SCL,0 Note first argument XYN INCRA OCICL,DESCR Increment offset GETD YPTR,OCBSCL,OCICL Get object code descriptor TESTF YPTR,FNC,,XYC Check for function XY1 AEQLC INSW,0,,XY2 Check &INPUT LOCAPV ZPTR,INATL,YPTR,XY2 Look for input association GETDC ZPTR,ZPTR,DESCR Get input association RCALL YPTR,PUTIN,(ZPTR,YPTR),FAIL * Perform input XY3 AEQLC SCL,0,RTN2 Check for completion SETAC SCL,1 Note seconf argument MOVD XPTR,YPTR Set up first argument BRANCH XYN Go around again *_ XY2 GETDC YPTR,YPTR,DESCR Get value BRANCH XY3 Continue *_ XYC PUSH (SCL,XPTR) Save indicator and argument RCALL YPTR,INVOKE,(YPTR),(FAIL,XY4) * Evaluate function POP (XPTR,SCL) Restore indicator and argument BRANCH XY3 Join processing *_ XY4 POP (XPTR,SCL) Restore indicator and argument BRANCH XY1 Join processing *_ *---------------------------------------------------------------------* TITLE 'Arithmetic Operations, Predicates, and Functions' ADD PROC , X + Y SETAC SCL,1 BRANCH ARITH *_ DIV PROC ADD X / Y SETAC SCL,2 BRANCH ARITH *_ EXP PROC ADD X ** Y and X ^ Y SETAC SCL,3 BRANCH ARITH *_ MPY PROC ADD X * Y SETAC SCL,4 BRANCH ARITH *_ SUB PROC ADD X - Y SETAC SCL,5 BRANCH ARITH *_ EQ PROC ADD EQ(X,Y) SETAC SCL,6 BRANCH ARITH *_ GE PROC ADD GE(X,Y) SETAC SCL,7 BRANCH ARITH *_ GT PROC ADD GT(X,Y) SETAC SCL,8 BRANCH ARITH *_ LE PROC ADD LE(X,Y) SETAC SCL,9 BRANCH ARITH *_ LT PROC ADD LT(X,Y) SETAC SCL,10 BRANCH ARITH *_ NE PROC ADD NE(X,Y) SETAC SCL,11 BRANCH ARITH *_ REMDR PROC ADD REMDR(X,Y) SETAC SCL,12 BRANCH ARITH *_ ARITH PUSH SCL Save procedure switch RCALL ,XYARGS,,FAIL Evaluate arguments POP SCL Restore procedure switch SETAV DTCL,XPTR Set up data type pair MOVV DTCL,YPTR DEQL DTCL,IIDTP,,ARTHII INTEGER-INTEGER DEQL DTCL,IVDTP,,ARTHIV INTEGER-STRING DEQL DTCL,VIDTP,,ARTHVI STRING-INTEGER DEQL DTCL,VVDTP,,ARTHVV STRING-STRING DEQL DTCL,RRDTP,,ARTHRR REAL-REAL DEQL DTCL,IRDTP,,ARTHIR INTEGER-REAL DEQL DTCL,RIDTP,,ARTHRI REAL-INTEGER DEQL DTCL,VRDTP,,ARTHVR STRING-REAL DEQL DTCL,RVDTP,INTR1,ARTHRV * REAL-STRING *_ ARTHII SELBRA SCL,(AD,DV,EX,MP,SB,CEQ,CGE,CGT,CLE,CLT,CNE,RM) *_ ARTHVI LOCSP XSP,XPTR Get specifier SPCINT XPTR,XSP,,ARTHII Convert string to integer SPREAL XPTR,XSP,INTR1,ARTHRI * Convert to real if possible *_ ARTHIV LOCSP YSP,YPTR Get specifier SPCINT YPTR,YSP,,ARTHII Convert string to integer SPREAL YPTR,YSP,INTR1,ARTHIR * Convert to real if possible *_ ARTHVV LOCSP XSP,XPTR Get specifier SPCINT XPTR,XSP,,ARTHIV Convert string to integer SPREAL XPTR,XSP,INTR1,ARTHRV * Convert to real if possible *_ ARTHRR SELBRA SCL,(AR,DR,EXR,MR,SR,REQ,RGE,RGT,RLE,RLT,RNE,INTR1) *_ ARTHIR INTRL XPTR,XPTR Convert integer to real BRANCH ARTHRR *_ ARTHRI INTRL YPTR,YPTR Convert integer to real BRANCH ARTHRR *_ ARTHVR LOCSP XSP,XPTR Get spedifier SPCINT XPTR,XSP,,ARTHIR Convert string to integer SPREAL XPTR,XSP,INTR1,ARTHRR * Convert to real if possible *_ ARTHRV LOCSP YSP,YPTR SPCINT YPTR,YSP,,ARTHRI Convert string to integer SPREAL YPTR,YSP,INTR1,ARTHRR * Convert to real if possible *_ AD SUM ZPTR,XPTR,YPTR,AERROR,ARTN *_ DV DIVIDE ZPTR,XPTR,YPTR,AERROR,ARTN *_ EX EXPINT ZPTR,XPTR,YPTR,AERROR,ARTN *_ MP MULT ZPTR,XPTR,YPTR,AERROR,ARTN *_ SB SUBTRT ZPTR,XPTR,YPTR,AERROR,ARTN *_ CEQ AEQL XPTR,YPTR,FAIL,RETNUL *_ CGE ACOMP XPTR,YPTR,RETNUL,RETNUL,FAIL *_ CGT ACOMP XPTR,YPTR,RETNUL,FAIL,FAIL *_ CLE ACOMP XPTR,YPTR,FAIL,RETNUL,RETNUL *_ CLT ACOMP XPTR,YPTR,FAIL,FAIL,RETNUL *_ CNE AEQL XPTR,YPTR,RETNUL,FAIL *_ AR ADREAL ZPTR,XPTR,YPTR,AERROR,ARTN *_ DR DVREAL ZPTR,XPTR,YPTR,AERROR,ARTN *_ EXR EXREAL ZPTR,XPTR,YPTR,AERROR,ARTN *_ MR MPREAL ZPTR,XPTR,YPTR,AERROR,ARTN *_ SR SBREAL ZPTR,XPTR,YPTR,AERROR,ARTN *_ REQ RCOMP XPTR,YPTR,FAIL,RETNUL,FAIL *_ RGE RCOMP XPTR,YPTR,RETNUL,RETNUL,FAIL *_ RGT RCOMP XPTR,YPTR,RETNUL,FAIL,FAIL *_ RLE RCOMP XPTR,YPTR,FAIL,RETNUL,RETNUL *_ RLT RCOMP XPTR,YPTR,FAIL,FAIL,RETNUL *_ RNE RCOMP XPTR,YPTR,RETNUL,FAIL,RETNUL *_ RM DIVIDE ZPTR,XPTR,YPTR,AERROR * First divide MULT WPTR,ZPTR,YPTR Multiply truncated part SUBTRT ZPTR,XPTR,WPTR Get difference BRANCH ARTN *_ *---------------------------------------------------------------------* * * INTEGER(X) * INTGER PROC , INTEGER(X) RCALL XPTR,ARGVAL,,FAIL Get argument VEQLC XPTR,I,,RETNUL INTEGER succeeds VEQLC XPTR,S,FAIL STRING must be checked LOCSP XSP,XPTR Get specifier SPCINT XPTR,XSP,FAIL,RETNUL * Try conversion to INTEGER *_ *---------------------------------------------------------------------* * * Arithmetic Negative * MNS PROC , -X RCALL XPTR,ARGVAL,,FAIL Get argument VEQLC XPTR,I,,MNSM INTEGER acceptable VEQLC XPTR,S,,MNSV STRING must be converted VEQLC XPTR,R,INTR1,MNSR REAL is acceptable *_ MNSM MNSINT ZPTR,XPTR,AERROR,ARTN * Form negative of integer *_ MNSV LOCSP XSP,XPTR Get specifier for string SPCINT XPTR,XSP,,MNSM Convert to INTEGER SPREAL XPTR,XSP,INTR1 Convert to REAL MNSR MNREAL ZPTR,XPTR Form negative of real BRANCH ARTN *_ *---------------------------------------------------------------------* * * Unary Plus Operator * PLS PROC , +X RCALL ZPTR,ARGVAL,,FAIL Get argument VEQLC ZPTR,I,,ARTN Is it INTEGER? VEQLC ZPTR,S,,PLSV Is it STRING? VEQLC ZPTR,R,INTR1,ARTN Is it REAL? *_ PLSV LOCSP XSP,ZPTR Get specifier SPCINT ZPTR,XSP,,ARTN Convert STRING to INTEGER SPREAL ZPTR,XSP,INTR1,ARTN Convert STRING to REAL *_ *---------------------------------------------------------------------* TITLE 'Pattern-valued Functions and Operations' ANY PROC , ANY(S) PUSH ANYCCL Save function descriptor BRANCH CHARZ Join common processing *_ BREAK PROC ANY BREAK(S) PUSH BRKCCL Save function descriptor PUSH ZEROCL Save minimum length of zero BRANCH ABNSND Join common processing *_ NOTANY PROC ANY NOTANY(S) PUSH NNYCCL Save function descriptor BRANCH CHARZ *_ SPAN PROC ANY SPAN(S) PUSH SPNCCL Save function descriptor CHARZ PUSH CHARCL Save minimum length of one ABNSND RCALL XPTR,ARGVAL,,FAIL Evaluate argument POP (ZCL,YCL) Restore descriptor and length VEQLC XPTR,S,,PATNOD STRING is acceptable argument VEQLC XPTR,E,,PATNOD So is EXPRESSION VEQLC XPTR,I,INTR1 INTEGER must be converted RCALL XPTR,GNVARI,XPTR PATNOD DEQL XPTR,NULVCL,,NONAME E3.5.4 RCALL TPTR,BLOCK,LNODSZ E3.5.4 MAKNOD ZPTR,TPTR,ZCL,ZEROCL,YCL,XPTR * Construct the pattern BRANCH RTZPTR *_ LEN PROC ANY LEN(N) PUSH LNTHCL Save function descriptor BRANCH LPRTND *_ POS PROC ANY POS(N) PUSH POSICL Save function descriptor BRANCH LPRTND *_ RPOS PROC ANY RPOS(N) PUSH RPSICL Save function descriptor BRANCH LPRTND *_ RTAB PROC ANY RTAB(N) PUSH RTBCL Save function descriptor BRANCH LPRTND *_ TAB PROC ANY TAB(N) PUSH TBCL Save function descriptor LPRTND RCALL XPTR,ARGVAL,,FAIL Evaluate argument POP YCL Restore function descriptor MOVD ZCL,ZEROCL Predict minimum length of zero VEQLC XPTR,I,,LPRTNI If INTEGER check for LEN VEQLC XPTR,E,,PATNOD EXPRESSION is acceptable VEQLC XPTR,S,INTR1 STRING must be converted to INTEGER LOCSP ZSP,XPTR Get specifier SPCINT XPTR,ZSP,INTR1 Convert to INTEGER LPRTNI ACOMPC XPTR,0,,,LENERR E3.6.1 DEQL YCL,LNTHCL,PATNOD E3.6.1 MOVA ZCL,XPTR If so, use value of integer BRANCH PATNOD Go form pattern *_ *---------------------------------------------------------------------* * * ARBNO(P) * ARBNO PROC , ARBNO(P) RCALL XPTR,PATVAL,,FAIL Evaluate argument as pattern VEQLC XPTR,P,,ARBP PATTERN is desired form VEQLC XPTR,S,INTR1 STRING must be made into PATTERN LOCSP TSP,XPTR Get specifier GETLG TMVAL,TSP Get length of string RCALL TPTR,BLOCK,LNODSZ Allocate block for argument MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR ARBP GETSIZ XSIZ,XPTR Get size of pattern SUM TSIZ,XSIZ,ARBSIZ Add additional space for ARBNO node SETVC TSIZ,P Insert PATTERN data type RCALL TPTR,BLOCK,TSIZ Allocate block for pattern MOVD ZPTR,TPTR Save pointer to return GETSIZ TSIZ,ARHEAD Set up copy for heading node CPYPAT TPTR,ARHEAD,ZEROCL,ZEROCL,ZEROCL,TSIZ SUM ZSIZ,XSIZ,TSIZ CPYPAT TPTR,XPTR,ZEROCL,TSIZ,ZSIZ,XSIZ SUM TSIZ,NODSIZ,NODSIZ Set up size for trailing node CPYPAT TPTR,ARTAIL,ZEROCL,ZSIZ,ZEROCL,TSIZ SUM ZSIZ,TSIZ,ZSIZ Set up size for backup node CPYPAT TPTR,ARBACK,ZEROCL,ZSIZ,TSIZ,TSIZ BRANCH RTZPTR *_ *---------------------------------------------------------------------* * * @X * ATOP PROC , @X INCRA OCICL,DESCR Increment interpreter offset GETD YPTR,OCBSCL,OCICL Get object code descriptor TESTF YPTR,FNC,ATOP1 Test for function descriptor RCALL YPTR,INVOKE,YPTR,(FAIL,ATOP1,) VEQLC YPTR,E,NEMO Only EXPRESSION can be value ATOP1 RCALL TPTR,BLOCK,LNODSZ Allocate pattern node MAKNOD ZPTR,TPTR,ZEROCL,ZEROCL,ATOPCL,YPTR BRANCH RTZPTR *_ *---------------------------------------------------------------------* * * Value Assignment Operators * NAM PROC , X . Y PUSH ENMECL Save function descriptor BRANCH NAM5 Join processing *_ DOL PROC NAM X $ Y PUSH ENMICL Save function descritpor NAM5 RCALL XPTR,PATVAL,,FAIL Get pattern for first argument INCRA OCICL,DESCR Increment offset GETD YPTR,OCBSCL,OCICL Get object code descriptor TESTF YPTR,FNC,,NAMC2 Check for function NAM3 VEQLC XPTR,S,,NAMV Is first argument STRING? VEQLC XPTR,P,INTR1,NAMP Is it PATTERN? *_ NAMC2 PUSH XPTR Save first argument RCALL YPTR,INVOKE,YPTR,(FAIL,NAM4,) * Evaluate second argument VEQLC YPTR,E,NEMO Verify EXPRESSION NAM4 POP XPTR Restore first argument BRANCH NAM3 Join processing *_ NAMV LOCSP TSP,XPTR Get specifier GETLG TMVAL,TSP Get length RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR * Make pattern node NAMP RCALL TPTR,BLOCK,SNODSZ Allocate block for pattern MAKNOD WPTR,TPTR,ZEROCL,ZEROCL,NMECL * Make node for naming RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern POP TVAL Restore function descriptor MAKNOD YPTR,TPTR,ZEROCL,ZEROCL,TVAL,YPTR * Make pattern for backup GETSIZ XSIZ,XPTR Get size of first pattern SUM YSIZ,XSIZ,NODSIZ Compute total size GETSIZ TSIZ,YPTR Get size of naming node SUM ZSIZ,YSIZ,TSIZ Compute total SETVC ZSIZ,P Insert PATTERN data type RCALL TPTR,BLOCK,ZSIZ Allocate block for total pattern MOVD ZPTR,TPTR Save copy LVALUE TVAL,XPTR Get least value CPYPAT TPTR,WPTR,TVAL,ZEROCL,NODSIZ,NODSIZ * Copy three patterns CPYPAT TPTR,XPTR,ZEROCL,NODSIZ,YSIZ,XSIZ CPYPAT TPTR,YPTR,ZEROCL,YSIZ,ZEROCL,TSIZ BRANCH RTZPTR Return pattern as value *_ *---------------------------------------------------------------------* * * Binary Alternation Operator * OR PROC , X | Y RCALL XPTR,PATVAL,,FAIL Get first argument PUSH XPTR Save first argument RCALL YPTR,PATVAL,,FAIL Get second argument POP XPTR Restore first argument SETAV DTCL,XPTR Get first data type MOVV DTCL,YPTR Insert second data type DEQL DTCL,VVDTP,,ORVV Is it STRING-STRING? DEQL DTCL,VPDTP,,ORVP Is it STRING-PATTERN? DEQL DTCL,PVDTP,,ORPV Is it PATTERN-STRING? DEQL DTCL,PPDTP,INTR1,ORPP * Is it PATTERN_PATTERN? *_ ORVV LOCSP XSP,XPTR Get specifier GETLG TMVAL,XSP Get length RCALL TPTR,BLOCK,LNODSZ Get block for pattern MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR * Construct pattern ORPV LOCSP YSP,YPTR Get specifier GETLG TMVAL,YSP Get length RCALL TPTR,BLOCK,LNODSZ Get block for pattern MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR * Construct pattern ORPP GETSIZ XSIZ,XPTR Get size of first pattern GETSIZ YSIZ,YPTR Get size of second pattern SUM TSIZ,XSIZ,YSIZ Compute total size SETVC TSIZ,P Insert PATTERN data type RCALL TPTR,BLOCK,TSIZ Allocate block for pattern MOVD ZPTR,TPTR Save copy CPYPAT TPTR,XPTR,ZEROCL,ZEROCL,ZEROCL,XSIZ * Copy first pattern CPYPAT TPTR,YPTR,ZEROCL,XSIZ,ZEROCL,YSIZ * Copy second pattern LINKOR ZPTR,XSIZ Link alternatives BRANCH RTZPTR Return pattern as value *_ ORVP LOCSP XSP,XPTR Get specifier GETLG TMVAL,XSP Get length RCALL TPTR,BLOCK,LNODSZ Get block for pattern MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR * Construct pattern BRANCH ORPP Join processing *_ *---------------------------------------------------------------------* TITLE 'Pattern Matching Procedures' * * Simple Pattern Matching * SCAN PROC , Pattern Matching RCALL XPTR,ARGVAL,,FAIL Get subject PUSH XPTR Save subject RCALL YPTR,PATVAL,,FAIL Get pattern POP XPTR Restore subject SETAV DTCL,XPTR Set up data type pair MOVV DTCL,YPTR INCRA SCNCL,1 Increment count of scanner entries DEQL DTCL,VVDTP,,SCANVV Is it STRING-STRING? DEQL DTCL,VPDTP,,SCANVP Is it STRING-PATTERN? DEQL DTCL,IVDTP,,SCANIV Is it INTEGER-STRING? DEQL DTCL,RVDTP,,SCANRV Is it REAL-STRING? DEQL DTCL,RPDTP,,SCANRP Is it REAL-PATTERN? DEQL DTCL,IPDTP,INTR1,SCANIP * Is it INTEGER-PATTERN? *_ SCANVV LOCSP XSP,XPTR Get specifier for subject LOCSP YSP,YPTR Get specifier for pattern SCANVB SUBSP TSP,YSP,XSP,FAIL Get part to compare LEXCMP TSP,YSP,,RETNUL Compare strings AEQLC ANCCL,0,FAIL Check &ANCHOR FSHRTN XSP,1 Delete lead character BRANCH SCANVB Try again *_ SCANIV RCALL XPTR,GNVARI,XPTR Generate variable for integer BRANCH SCANVV Join processing *_ SCANVP LOCSP XSP,XPTR Get specifier for subject RCALL ,SCNR,,(FAIL,,FAIL) Call scanner RCALL ,NMD,,(FAIL,RTN2) Perform naming *_ SCANIP RCALL XPTR,GNVARI,XPTR Generate variable for integer BRANCH SCANVP Join processing *_ SCANRV REALST XSP,XPTR Convert REAL to STRING RCALL XPTR,GENVAR,XSPPTR,SCANVV *_ SCANRP REALST XSP,XPTR Convert REAL to STRING RCALL XPTR,GENVAR,XSPPTR,SCANVP * Generate variable *_ *_ *---------------------------------------------------------------------* * * Pattern Matching with Replacement * SJSR PROC , Pattern matching with replacement INCRA OCICL,DESCR Increment offset GETD WPTR,OCBSCL,OCICL Get object code descriptor TESTF WPTR,FNC,,SJSRC1 Check for function SJSR1 AEQLC INSW,0,,SJSR1A Check &INPUT LOCAPV ZPTR,INATL,WPTR,SJSR1A * Look of input association GETDC ZPTR,ZPTR,DESCR Get association RCALL XPTR,PUTIN,(ZPTR,WPTR),(FAIL,SJSR1B) * Perform input *_ SJSR1A GETDC XPTR,WPTR,DESCR Get value SJSR1B PUSH (WPTR,XPTR) Save name and value RCALL YPTR,PATVAL,,FAIL Get pattern POP XPTR Restore value SETAV DTCL,XPTR Set up data type pair MOVV DTCL,YPTR INCRA SCNCL,1 Increment count of scanner calls DEQL DTCL,VVDTP,,SJSSVV Is it STRING-PATTERN? DEQL DTCL,VPDTP,,SJSSVP Is it INTEGER-STRING? DEQL DTCL,IVDTP,,SJSSIV Is it INTEGER-PATTERN? DEQL DTCL,RVDTP,,SJSSRV Is it REAL-STRING? DEQL DTCL,RPDTP,,SJSSRP Is it REAL-PATTERN? DEQL DTCL,IPDTP,INTR1,SJSSIP *_ SJSRC1 RCALL WPTR,INVOKE,(WPTR),(FAIL,SJSR1,NEMO) * Evaluate subject *_ SJSSVP LOCSP XSP,XPTR Get specifier RCALL ,SCNR,,(FAIL,,FAIL) Call scanner SETAC NAMGCL,1 Set naming switch REMSP TAILSP,XSP,TXSP Get tail of subject BRANCH SJSS1 Join common processing *_ SJSSIP RCALL XPTR,GNVARI,XPTR Generate STRING from INTEGER BRANCH SJSSVP Join common processing *_ SJSSIV RCALL XPTR,GNVARI,XPTR Generate STRING from INTEGER BRANCH SJSSVV Join common processing *_ SJSSRV REALST XSP,XPTR Convert REAL to STRING RCALL XPTR,GENVAR,XSPPTR,SJSSVV * Generate variable *_ SJSSRP REALST XSP,XPTR Convert REAL to STRING RCALL XPTR,GENVAR,XSPPTR,SJSSVP * Generate variable *_ SJVVON AEQLC ANCCL,0,FAIL Check &ANCHOR ADDLG HEADSP,ONECL Increment length of head FSHRTN XSP,1 Delete head character BRANCH SJSSV2 Join common processing *_ SJSSVV LOCSP XSP,XPTR Get specifier for subject LOCSP YSP,YPTR Get specifier for pattern SETSP HEADSP,XSP Set up head specifier SETLC HEADSP,0 Initialize zero length SJSSV2 SUBSP TSP,YSP,XSP,FAIL Get common length LEXCMP TSP,YSP,SJVVON,,SJVVON * Compare strings SETAC NAMGCL,0 Clear naming switch REMSP TAILSP,XSP,TSP Get tail of subject SJSS1 SPUSH (TAILSP,HEADSP) Save head and tail AEQLC NAMGCL,0,,SJSS1A Check naming switch RCALL ,NMD,,FAIL Perform naming SJSS1A RCALL ZPTR,ARGVAL,,FAIL Get object SPOP (HEADSP,TAILSP) Restore head and tail POP WPTR Restore name of subject LEQLC HEADSP,0,SJSSDT Check for null head LEQLC TAILSP,0,,SJSRV1 Check for null tail SJSSDT VEQLC ZPTR,S,,SJSRV Is object STRING? VEQLC ZPTR,P,,SJSRP Is object PATTERN? VEQLC ZPTR,I,,SJSRI Is object INTEGER? VEQLC ZPTR,R,,SJSRR Is object REAL? VEQLC ZPTR,E,INTR1 Is object EXPRESSION? RCALL TPTR,BLOCK,STARSZ Allocate block for pattern MOVBLK TPTR,STRPAT,STARSZ Set up pattern for expression PUTDC TPTR,4*DESCR,ZPTR Insert object MOVD ZPTR,TPTR Set up converted value SJSRP SETSP XSP,HEADSP Copy specifier RCALL XPTR,GENVAR,(XSPPTR) * Generate variable for head GETLG TMVAL,HEADSP Get length of head RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR * Make pattern node SETSP YSP,TAILSP Set up tail specifier RCALL YPTR,GENVAR,(YSPPTR) * Generate variable for tail GETLG TMVAL,TAILSP Get length of tail RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR * Make pattern node GETSIZ XSIZ,XPTR Get size of head node GETSIZ YSIZ,YPTR Get size of tail node GETSIZ ZSIZ,ZPTR Get size of object SUM TSIZ,XSIZ,ZSIZ Compute total size SUM TSIZ,TSIZ,YSIZ Get size of new pattern SETVC TSIZ,P Insert PATTERN data type RCALL TPTR,BLOCK,TSIZ Allocate block for total pattern MOVD VVAL,TPTR Get working copy LVALUE TVAL,ZPTR Get least value of replacement CPYPAT TPTR,XPTR,TVAL,ZEROCL,XSIZ,XSIZ * Copy in head LVALUE TVAL,YPTR Get least value of tail SUM TSIZ,XSIZ,ZSIZ Get size of first two CPYPAT TPTR,ZPTR,TVAL,XSIZ,TSIZ,ZSIZ * Copy in object CPYPAT TPTR,YPTR,ZEROCL,TSIZ,ZEROCL,YSIZ * Copy in tail MOVD ZPTR,VVAL Set up return value BRANCH SJSRV1 Join common processing *_ SJSRV LOCSP ZSP,ZPTR SJSRS GETLG XPTR,TAILSP Get length of tail GETLG YPTR,HEADSP Get length of tail GETLG ZPTR,ZSP Get length of object SUM XPTR,XPTR,YPTR Compute total length SUM XPTR,XPTR,ZPTR ACOMP XPTR,MLENCL,INTR8 Check &MAXLNGTH RCALL ZPTR,CONVAR,(XPTR) Allocate storage for string LOCSP TSP,ZPTR Get specifier SETLC TSP,0 Clear length APDSP TSP,HEADSP Append head APDSP TSP,ZSP Append object APDSP TSP,TAILSP Append tail RCALL ZPTR,GNVARS,XPTR Enter string into storage SJSRV1 PUTDC WPTR,DESCR,ZPTR Assign value to subject name AEQLC OUTSW,0,,SJSRV2 Check &OUTPUT LOCAPV YPTR,OUTATL,WPTR,SJSRV2 * Look for output association GETDC YPTR,YPTR,DESCR Get output association RCALL ,PUTOUT,(YPTR,ZPTR) Perform output SJSRV2 ACOMPC TRAPCL,0,,RTN3,RTN3 Check &TRACE LOCAPT ATPTR,TVALL,WPTR,RTN3 * Look for VALUE trace RCALL ,TRPHND,ATPTR,RTN3 E3.3.1 * Perform trace *_ SJSRI INTSPC ZSP,ZPTR Convert INTEGER BRANCH SJSRS *_ SJSRR REALST ZSP,ZPTR Convert REAL BRANCH SJSRS *_ *---------------------------------------------------------------------* * * Basic Scanning Procedure * SCNR PROC , Scanning procedure GETLG MAXLEN,XSP Get maximum length LVALUE YSIZ,YPTR Get least value AEQLC FULLCL,0,SCNR1 Check &FULLSCAN ACOMP YSIZ,MAXLEN,FAIL CHeck maximum against minimum SCNR1 SETSP TXSP,XSP Set up working specifier for head SETLC TXSP,0 Zero length MOVD PDLPTR,PDLHED Initialize history list MOVD NAMICL,NHEDCL Initialize name list AEQLC ANCCL,0,SCNR3 Check &ANCHOR AEQLC FULLCL,0,,SCNR4 Check &FULLSCAN MOVD YSIZ,MAXLEN Set up length BRANCH SCNR5 Join processing *_ SCNR4 SUBTRT YSIZ,MAXLEN,YSIZ Get difference of lengths SCNR5 SUM YSIZ,YSIZ,CHARCL Add one SCNR2 PUSH (YPTR,YSIZ) Save pattern and length SETSP HEADSP,TXSP Set up head specifier INCRA PDLPTR,3*DESCR Make room for history entry ACOMP PDLPTR,PDLEND,INTR31 * Check for overflow SETAC LENFCL,1 Set length failure PUTDC PDLPTR,DESCR,SCONCL Insert scan function GETLG TMVAL,TXSP Get cursor position PUTDC PDLPTR,2*DESCR,TMVAL * Insert on history list PUTDC PDLPTR,3*DESCR,LENFCL * Insert length failure BRANCH SCIN1 Join common scanning *_ SCNR3 INCRA PDLPTR,3*DESCR Make room for history entry ACOMP PDLPTR,PDLEND,INTR31 * Check for overflow SETLC HEADSP,0 Zero length of head PUTDC PDLPTR,DESCR,SCFLCL Insert scan failure function GETLG TMVAL,TXSP Get cursor position PUTDC PDLPTR,2*DESCR,TMVAL * Insert on history list PUTDC PDLPTR,3*DESCR,LENFCL * Insert length failure BRANCH SCIN1 Join common scanning *_ SCIN PROC SCNR SCIN1 MOVD PATBCL,YPTR Set up pattern base pointer SETAC PATICL,0 Zero offset SCIN2 SETAC LENFCL,1 Set length failure SCIN3 INCRA PATICL,DESCR Increment offset GETD ZCL,PATBCL,PATICL Get function descriptor INCRA PATICL,DESCR Increment offset GETD XCL,PATBCL,PATICL Get then-or descriptor INCRA PATICL,DESCR Increment offset GETD YCL,PATBCL,PATICL Get value-residual descriptor INCRA PDLPTR,3*DESCR Make room for history entry ACOMP PDLPTR,PDLEND,INTR31 * Check for overflow PUTDC PDLPTR,DESCR,XCL Insert then-or descriptor GETLG TMVAL,TXSP Get cursor position MOVV TMVAL,YCL Insert residual PUTDC PDLPTR,2*DESCR,TMVAL * Insert on history list PUTDC PDLPTR,3*DESCR,LENFCL * Insert length failure AEQLC FULLCL,0,SCIN4 Check &FULLSCAN CHKVAL MAXLEN,YCL,TXSP,SALT1 * Check values SCIN4 BRANIC ZCL,0 Branch to procedure *_ SALF PROC SCNR Nonlength failure procedure SALF1 SETAC LENFCL,0 Clear length failure BRANCH SALT2 Join common processing *_ SALT PROC SCNR Length failure procedure SALT1 GETDC LENFCL,PDLPTR,3*DESCR * Get length failure from history SALT2 GETDC XCL,PDLPTR,DESCR Get then-or descriptor GETDC YCL,PDLPTR,2*DESCR Get value-residual DECRA PDLPTR,3*DESCR Back over history entry MOVD PATICL,XCL Set offset to OR link AEQLC PATICL,0,,SALT3 Check for none PUTLG TXSP,YCL Insert old length of head TESTF PATICL,FNC,SCIN3 Check for function BRANIC PATICL,0 Branch to procedure *_ SALT3 AEQLC LENFCL,0,SALT1 Check length failure BRANCH SALF1 Go to nonlength failure *_ SCOK PROC SCNR Successful scanning procedure SETAV PATICL,XCL Set offset from THEN link AEQLC PATICL,0,SCIN2,RTN2 Check for none *_ SCON PROC SCNR AEQLC FULLCL,0,SCON1 Check &FULLSCAN AEQLC LENFCL,0,FAIL Check length failure SCON1 POP (YSIZ,YPTR) Restore save descriptors DECRA YSIZ,1 Decrement possible count ACOMPC YSIZ,0,,FAIL,INTR13 CHeck for end ADDLG TXSP,ONECL Increment length of head BRANCH SCNR2 Continue *_ UNSC PROC SCNR Backout procedure MOVD PATBCL,YPTR Reset pattern base BRANCH SALT3 Join processing *_ *---------------------------------------------------------------------* * * ANY, BREAK, NOTANY, SPAN * ANYC PROC , Matching procedure for ANY(S) SETAC SCL,1 Post entry ABNS INCRA PATICL,DESCR Increment offset GETD XPTR,PATBCL,PATICL Get argument PUSH SCL Save processor switch ABNS1 VEQLC XPTR,S,,ABNSV E3.5.5 VEQLC XPTR,E,,ABNSE EXPRESSION must be evaluated VEQLC XPTR,I,,ABNSI E3.5.6 POP SCL E3.5.6 BRANCH SCDTER E3.5.6 *_ E3.5.6 ABNSE RCALL XPTR,EXPVAL,XPTR,(ABNSF,ABNS1) E3.5.5 *_ E3.5.5 ABNSF POP SCL E3.5.5 BRANCH TSALF E3.5.5 *_ E3.5.5 ABNSI RCALL XPTR,GNVARI,XPTR ABNSV POP SCL Restore procedure switch AEQLC XPTR,0,,SCNAME E3.5.5 SELBRA SCL,(,BRKV,NNYV,SPNV) * Select processor ANYV DEQL XPTR,TBLCS,ANYC2 Was last argument the same? AEQL TBLFNC,ANYCCL,,ANYC3 * If so, was last procedure for ANY(S) ANYC2 CLERTB SNABTB,ERROR If not, clear stream table LOCSP YSP,XPTR PLUGTB SNABTB,STOP,YSP Plug entries for characters MOVD TBLCS,XPTR Save argument to check next time MOVD TBLFNC,ANYCCL Save procedure to check next time ANYC3 SETSP VSP,XSP Set up working specifier AEQLC FULLCL,0,ANYC4 Leave length alone in FULLSCAN mode PUTLG VSP,MAXLEN Else insert maximum length LCOMP VSP,TXSP,,,TSALT Length failure if too short CHKVAL MAXLEN,ZEROCL,XSP,,ANYC4,ANYC4 E3.5.7 ADDLG VSP,ONECL E3.5.7 ANYC4 REMSP YSP,VSP,TXSP Get specifier to unscanned portion STREAM ZSP,YSP,SNABTB,TSALF,TSALT GETLG XPTR,ZSP Get length accepted ADDLG TXSP,XPTR Add to length matched BRANCH SCOK,SCNR Return to success point *_ BRKC PROC ANYC Matching procedure for BREAK(S) SETAC SCL,2 Post entry BRANCH ABNS *_ BRKV DEQL XPTR,TBLCS,BRKC2 Was last argument the same? AEQL TBLFNC,BRKCCL,,ANYC3 * Was the last procedure for BREAK BRKC2 CLERTB SNABTB,CONTIN If not, clear stream table LOCSP YSP,XPTR PLUGTB SNABTB,STOPSH,YSP Plug entries for characters MOVD TBLCS,XPTR Save argument to check next time MOVD TBLFNC,BRKCCL Save procedure to check next time BRANCH ANYC3 Proceed *_ NNYC PROC ANYC Matching procedure for NOTANY(S) SETAC SCL,3 Post entry BRANCH ABNS *_ NNYV DEQL XPTR,TBLCS,NNYC2 Was last argument the same? AEQL TBLFNC,NNYCCL,,ANYC3 * Was the last procedure for NOTANY? NNYC2 CLERTB SNABTB,STOP If not, clear stream table LOCSP YSP,XPTR PLUGTB SNABTB,ERROR,YSP Plug entries for characters MOVD TBLCS,XPTR Save argument to check next time MOVD TBLFNC,NNYCCL Save procedure to check next time BRANCH ANYC3 Proceed *_ SPNC PROC ANYC Matching procedure for SPAN(S) SETAC SCL,4 Post entry BRANCH ABNS *_ SPNV DEQL XPTR,TBLCS,SPNC2 Was last argument the same? AEQL TBLFNC,SPNCCL,,SPNC3 * Was the last procedure for SPAN? SPNC2 CLERTB SNABTB,STOPSH If not, clear stream table LOCSP YSP,XPTR PLUGTB SNABTB,CONTIN,YSP Plug entries for characters MOVD TBLCS,XPTR Save argument to check next time MOVD TBLFNC,SPNCCL Save procedure to check next time SPNC3 LCOMP XSP,TXSP,,TSALT,TSALT * Length failure if too short REMSP YSP,XSP,TXSP Get specifier to unscanned portion STREAM ZSP,YSP,SNABTB,TSALF LEQLC ZSP,0,,TSALF Failure if length accepted is zero GETLG XPTR,ZSP Get length of accepted portion AEQLC FULLCL,0,SPNC5 Skip length check in FULLSCAN mode CHKVAL MAXLEN,XPTR,TXSP,TSALT SPNC5 ADDLG TXSP,XPTR Add length accepted BRANCH SCOK,SCNR *_ *---------------------------------------------------------------------* * * LEN, POS, RPOS, RTAB, TAB * LNTH PROC , Matching procedure for LEN(N) SETAC SCL,1 Note entry LPRRT INCRA PATICL,DESCR Increment offset GETD XPTR,PATBCL,PATICL Get argument PUSH SCL Save entry indicator * LPRRT1 VEQLC XPTR,I,,LPRRTI Is it INTEGER? VEQLC XPTR,E,,LPRRTE Is it EXPRESSION? VEQLC XPTR,S,,LPRRTV E3.5.6 POP SCL E3.5.6 BRANCH SCDTER E3.5.6 * Is it STRING? LPRRTE RCALL XPTR,EXPVAL,XPTR,(,LPRRT1) E3.2.1 POP SCL E3.2.1 BRANCH TSALF E3.2.1 *_ E3.2.1 * Evaluate EXPRESSION LPRRTV LOCSP ZSP,XPTR Get specifier SPCINT XPTR,ZSP,SCDTER Convert to INTEGER LPRRTI POP SCL Restore entry indicator SELBRA SCL,(,POSII,RPSII,RTBI,TBI) * Select matching procedure ACOMPC XPTR,0,,,SCLENR Check for negative length CHKVAL MAXLEN,XPTR,TXSP,TSALT * Compare with maximum length ADDLG TXSP,XPTR Add to length matched BRANCH SCOK,SCNR Return successful match *_ POSII ACOMPC XPTR,0,,,SCLENR Check for negative position GETLG NVAL,TXSP Get cursor position ACOMP XPTR,MAXLEN,TSALT Check desired against maximum ACOMP XPTR,NVAL,TSALF,TSCOK * Ceck against cursor position BRANCH SALT,SCNR *_ RPSII ACOMPC XPTR,0,,,SCLENR Check for negative position GETLG NVAL,XSP Get total length SUBTRT TVAL,NVAL,XPTR Find desired position GETLG NVAL,TXSP Get cursor position ACOMP NVAL,TVAL,TSALT,TSCOK,TSALF * Compare two positions *_ RTBI ACOMPC XPTR,0,,,SCLENR Check for negative length GETLG NVAL,XSP Get total length SUBTRT TVAL,NVAL,XPTR Find desired position GETLG NVAL,TXSP Get current position ACOMP NVAL,TVAL,TSALT Compare two positions AEQLC FULLCL,0,RTBII Check &FULLSCAN SETAV NVAL,YCL Get residual SUBTRT NVAL,MAXLEN,NVAL Find maximum allowed position ACOMP NVAL,TVAL,,,TSALT Compare with desired position RTBII PUTLG TXSP,TVAL Update length of string matched BRANCH SCOK,SCNR *_ TBI ACOMPC XPTR,0,,,SCLENR Check for negative length GETLG NVAL,TXSP Get cursor position ACOMP NVAL,XPTR,TSALT Check against desired position ACOMP XPTR,MAXLEN,TSALT Check for tab beyond end PUTLG TXSP,XPTR Update length of string matched BRANCH SCOK,SCNR *_ POSI PROC LNTH Matching procedure for POS(N) SETAC SCL,2 Note entry BRANCH LPRRT Join common processing *_ RPSI PROC LNTH Matching procedure for RPOS(N) SETAC SCL,3 Note entry BRANCH LPRRT Join common processing *_ RTB PROC LNTH Matching procedure for RTAB(N) SETAC SCL,4 Note entry BRANCH LPRRT Join common processing *_ TB PROC LNTH Matching procedure for TAB(N) SETAC SCL,5 Note entry BRANCH LPRRT Join common processing *_ *---------------------------------------------------------------------* * * ARBNO * ARBN PROC , Matching for ARBNO(P) GETLG TMVAL,TXSP Get cursor position PUSH TMVAL Save cursor position BRANCH SCOK,SCNR Return matching successfully *_ ARBF PROC ARBN Backup matching for ARBNO(P) POP (TMVAL) Restore cursor position BRANCH ONAR2 Join common processing *_ EARB PROC ARBN POP (TMVAL) Restore cursor position PUTDC PDLPTR,DESCR,TMVAL Insert on history list GETLG TMVAL,TXSP Get cursor position PUTDC PDLPTR,2*DESCR,TMVAL PUTDC PDLPTR,3*DESCR,ZEROCL BRANCH SCOK,SCNR Return matching successfully *_ ONAR PROC ARBN AEQLC FULLCL,0,TSCOK Check &FULLSCAN MOVD TVAL,ZEROCL GETAC TVAL,PDLPTR,-2*DESCR * Get old cursor position GETLG TMVAL,TXSP Get current cursor position ACOMP TVAL,TMVAL,TSCOK,,TSCOK * Compare positions ONAR1 PUSH TVAL Save cursor position DECRA PDLPTR,6*DESCR Delete history entries ONAR2 AEQLC LENFCL,0,TSALT Check length failure BRANCH SALF,SCNR Return matching failure *_ ONRF PROC ARBN MOVD TVAL,ZEROCL GETAC TVAL,PDLPTR,-2*DESCR * Get old cursor position BRANCH ONAR1 Join processing *_ FARB PROC , AEQLC FULLCL,0,,FARB2 Check &FULLSCAN SETAC NVAL,0 Set residual length to 0 BRANCH FARB3 Join processing *_ FARB2 AEQLC LENFCL,0,FARB1 Check for length failure SETAV NVAL,YCL Get residual length FARB3 GETLG TVAL,TXSP Get cursor position SUM TVAL,TVAL,NVAL Add them ACOMP TVAL,MAXLEN,FARB1,FARB1 * Check against maximum ADDLG TXSP,ONECL Add one for ARB GETLG TVAL,TXSP Get length matched PUTAC PDLPTR,2*DESCR,TVAL Insert on history list BRANCH SCOK,SCNR Return successful match *_ FARB1 DECRA PDLPTR,3*DESCR Back over history entry BRANCH SALT,SCNR *_ *---------------------------------------------------------------------* * * @X * ATP PROC , Matching procedure for @X INCRA PATICL,DESCR Increment pattern offset GETD XPTR,PATBCL,PATICL Get argument ATP1 VEQLC XPTR,E,,ATPEXN EXPRESSION must be evaluated GETLG NVAL,TXSP Get length of text matched SETVC NVAL,I Set INTEGER data type PUTDC XPTR,DESCR,NVAL Assign as value of variable X AEQLC OUTSW,0,,ATP2 Check &OUTPUT LOCAPV ZPTR,OUTATL,XPTR,ATP2 * Look for output association GETDC ZPTR,ZPTR,DESCR Get output association descriptor RCALL ,PUTOUT,(ZPTR,NVAL) Perform output ATP2 AEQLC TRAPCL,0,,TSCOK Check &TRACE LOCAPT ATPTR,TVALL,XPTR,TSCOK * Look for trace association PUSH (PATBCL,PATICL,WPTR,XCL,YCL) PUSH (MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL) SPUSH (HEADSP,TSP,TXSP,XSP) MOVD PDLHED,PDLPTR Set new stack heading MOVD NHEDCL,NAMICL Set new name list heading RCALL ,TRPHND,ATPTR E3.3.1 * Perform tracing SPOP (XSP,TXSP,TSP,HEADSP) POP (NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN) POP (YCL,XCL,WPTR,PATICL,PATBCL) BRANCH SCOK,SCNR *_ ATPEXN RCALL XPTR,EXPEVL,XPTR,(TSALF,ATP1,SCNEMO) E3.4.4 *_ *---------------------------------------------------------------------* * * BAL * BAL PROC , Matching procedure for BAL BALF1 AEQLC FULLCL,0,,BALF4 Check &FULLSCAN SETAC NVAL,0 Set length to zero BRANCH BALF2 *_ BALF4 SETAV NVAL,YCL BALF2 GETLG TVAL,TXSP Get length of text matched so far SUM TVAL,TVAL,NVAL Add remainder possible ACOMP TVAL,MAXLEN,BAL1,BAL1 * Compare to maximum SUBTRT TVAL,MAXLEN,TVAL Get maximum length for BAL GETBAL TXSP,TVAL,BAL1 Get balanced string GETLG TVAL,TXSP Get length matched PUTAC PDLPTR,2*DESCR,TVAL Insert history entry BRANCH SCOK,SCNR Successful match *_ BAL1 DECRA PDLPTR,3*DESCR Back over history entry ACOMP PDLPTR,PDLHED,TSALF,TSALF,INTR13 *_ BALF PROC BAL Matching procedure for BAL retry AEQLC FULLCL,0,,BALF3 Check &FULLSCAN SETAC NVAL,0 If off, set length to zero BRANCH BALF2 Reenter balanced matching *_ BALF3 AEQLC LENFCL,0,BAL1,BALF1 If on, test for length failure *_ *---------------------------------------------------------------------* * * Matching for String * CHR PROC , Matching character string INCRA PATICL,DESCR Increment offset GETD YPTR,PATBCL,PATICL Get argument CHR1 LOCSP TSP,YPTR Get specifier CHR2 REMSP VSP,XSP,TXSP Remove part matched SUBSP VSP,TSP,VSP,TSALT Get part to match LEXCMP VSP,TSP,TSALF,,TSALF * Compare strings GETLG YPTR,TSP Get length ADDLG TXSP,YPTR Update string matched BRANCH SCOK,SCNR Return successful match *_ *---------------------------------------------------------------------* * * *X * STAR PROC CHR Matching procedure for expressions INCRA PATICL,DESCR Increment offset GETD YPTR,PATBCL,PATICL Get argument expression STAR2 RCALL YPTR,EXPVAL,YPTR,TSALF * Evaluate argument VEQLC YPTR,E,,STAR2 Is is EXPRESSION? SUM XPTR,PATBCL,PATICL Compute pointer to argument PUTDC XPTR,7*DESCR,YPTR Insert pointer in backup node VEQLC YPTR,S,,CHR1 Is it STRING? VEQLC YPTR,P,,STARP Is it PATTERN? VEQLC YPTR,I,SCDTER Is it INTEGER? INTSPC TSP,YPTR Get specifier for integer BRANCH CHR2 Join processing *_ STARP AEQLC FULLCL,0,,STARP1 Check &FULLSCAN SETAC NVAL,0 Zero length BRANCH STARP4 Join processing *_ STARP1 SETAV NVAL,YCL Get length STARP4 SUBTRT NVAL,MAXLEN,NVAL Compute residual ACOMPC NVAL,0,,,TSALT LVALUE TSIZ,YPTR Check &FULLSCAN AEQLC FULLCL,0,STARP6 ACOMP TSIZ,NVAL,TSALT Check against length STARP6 INCRA PDLPTR,3*DESCR Make room for history ACOMP PDLPTR,PDLEND,INTR31 * Check for overflow PUTDC PDLPTR,DESCR,SCFLCL Insert failure function GETLG TMVAL,TXSP Get cursor position PUTDC PDLPTR,2*DESCR,TMVAL * Insert on history list PUTDC PDLPTR,3*DESCR,LENFCL * Insert length failure PUSH (MAXLEN,PATBCL,PATICL,XCL,YCL) * Save scanner state MOVD MAXLEN,NVAL Set up new maximum RCALL ,SCIN,,(STARP5,,RTNUL3) * Call the scanner STARP2 POP (YCL,XCL,PATICL,PATBCL,MAXLEN) * Restore scanner state BRANCH SCOK,SCNR Return matching successfully *_ STARP5 POP (YCL,XCL,PATICL,PATBCL,MAXLEN) * Restore scanner state STARP3 AEQLC LENFCL,0,TSALT Check length failure BRANCH SALF,SCNR Return matching failure *_ DSAR PROC CHR Backup matching for expression INCRA PATICL,DESCR Increment offset GETD YPTR,PATBCL,PATICL Get argument VEQLC YPTR,S,,STARP3 Is it STRING? VEQLC YPTR,P,,DSARP Is it PATTERN? VEQLC YPTR,I,SCDTER,STARP3 * Is it INTEGER? *_ DSARP AEQLC FULLCL,0,,DSARP1 Check &FULLSCAN SETAC NVAL,0 Zero length BRANCH DSARP2 Join processing *_ DSARP1 SETAV NVAL,YCL Get length DSARP2 SUBTRT NVAL,MAXLEN,NVAL Compute residual PUSH (MAXLEN,PATBCL,PATICL,XCL,YCL) * Save scanner state MOVD MAXLEN,NVAL Set up new maximum RCALL ,UNSC,,(STARP5,STARP2,RTNUL3) * Call unscanning procedure *_ *---------------------------------------------------------------------* * * FENCE * FNCE PROC , Procedure for matching FENCE INCRA PDLPTR,3*DESCR Create new history entry ACOMP PDLPTR,PDLEND,INTR31 * Check for overflow PUTDC PDLPTR,DESCR,FNCFCL Insert FENCE failure function GETLG TMVAL,TXSP Get length PUTDC PDLPTR,2*DESCR,TMVAL * Save length PUTDC PDLPTR,3*DESCR,LENFCL * Save length failure switch SETAC LENFCL,1 Set length failure switch BRANIC SCOKCL,0 Return matching *_ *---------------------------------------------------------------------* * * X . Y and X $ Y * NME PROC , Matching procedure for naming INCRA PDLPTR,3*DESCR Make room for history entry ACOMP PDLPTR,PDLEND,INTR31 * Check for end of list PUTDC PDLPTR,DESCR,FNMECL Insert backup function GETLG TMVAL,TXSP Get cursor position PUTDC PDLPTR,2*DESCR,TMVAL * Put on history list PUTDC PDLPTR,3*DESCR,LENFCL * Put length failure indicator PUSH (TMVAL) Save cursor SETAC LENFCL,1 Set length failure indicator BRANCH SCOK,SCNR Return matching successfully *_ FNME PROC NME Backup procedure for naming POP (TVAL) Restore cursor FNME1 AEQLC LENFCL,0,TSALT,TSALF * Check length failure indicator *_ ENME PROC NME Naming process for X . Y INCRA PATICL,DESCR Increment offset GETD YPTR,PATBCL,PATICL Get argument POP (NVAL) Restore previous cursor position SETVA YCL,NVAL Set up length SETSP TSP,TXSP Copy specifier PUTLG TSP,NVAL Insert length REMSP TSP,TXSP,TSP Compute ramainder SUM TPTR,NBSPTR,NAMICL Compute position on name list PUTSPC TPTR,DESCR,TSP Insert specifier PUTDC TPTR,DESCR+SPEC,YPTR * Insert argument INCRA NAMICL,DESCR+SPEC Increment list offset ACOMP NAMICL,NMOVER,INTR13,ENME1 * Check for overflow ENME2 INCRA PDLPTR,DESCR+SPEC Make room on history list ACOMP PDLPTR,PDLEND,INTR31 * Check for overflow PUTDC PDLPTR,DESCR,DNMECL Insert unravelling function ENME3 GETLG TMVAL,TXSP Get cursor position MOVV TMVAL,YCL PUTDC PDLPTR,2*DESCR,TMVAL * Insert on list PUTDC PDLPTR,3*DESCR,LENFCL * Insert length failure SETAC LENFCL,1 Set length failure BRANCH SCOK,SCNR Return matching successfully *_ ENME1 MOVD WCL,NMOVER Save copy of cuurent name list end INCRA NMOVER,NAMLSZ*SPDR Increment for larger block RCALL TPTR,BLOCK,NMOVER Allocate larger block MOVBLK TPTR,NBSPTR,WCL Move in old block MOVD NBSPTR,TPTR Set up new base pointer BRANCH ENME2 Rejoin processing *_ DNME PROC NME Unravelling procedure for naming DECRA NAMICL,DESCR+SPEC Back off named string SUM TPTR,NBSPTR,NAMICL Compute current position DNME1 PROC NME SETAV VVAL,YCL PUSH (VVAL) Preserve length BRANCH FNME1 *_ ENMI PROC NME Matching for X $ Y INCRA PATICL,DESCR Increment offset GETD YPTR,PATBCL,PATICL Get argument POP (NVAL) Restore initial length SETVA YCL,NVAL Move initial length into value field SETSP TSP,TXSP Get working specifier PUTLG TSP,NVAL Insert length REMSP TSP,TXSP,TSP Get specifier for part matched GETLG ZCL,TSP Get length of part ACOMP ZCL,MLENCL,SCLNOR Check &MAXLNGTH VEQLC YPTR,E,,ENMEXN Is it EXPRESSION? ENMI5 VEQLC YPTR,K,,ENMIC Check for KEYWORD data type RCALL VVAL,GENVAR,(TSPPTR) * Generate variable ENMI3 PUTDC YPTR,DESCR,VVAL Perform assignment AEQLC OUTSW,0,,ENMI4 Check &OUTPUT LOCAPV ZPTR,OUTATL,YPTR,ENMI4 * Look for output association GETDC ZPTR,ZPTR,DESCR Get association RCALL ,PUTOUT,(ZPTR,VVAL) Perform output ENMI4 ACOMPC TRAPCL,0,,ENMI2,ENMI2 * Check &TRACE LOCAPT ATPTR,TVALL,YPTR,ENMI2 * Look for VALUE trace PUSH (PATBCL,PATICL,WPTR,XCL,YCL) * Save relevant descriptors PUSH (MAXLEN,LENFCL,PDLPTR,PDLHED,NAMICL,NHEDCL) SPUSH (HEADSP,TSP,TXSP,XSP) * Save relevant specifiers MOVD PDLHED,PDLPTR Set up new history list head MOVD NHEDCL,NAMICL Set up new name list head RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace SPOP (XSP,TXSP,TSP,HEADSP) * Restore specifiers POP (NHEDCL,NAMICL,PDLHED,PDLPTR,LENFCL,MAXLEN) * Restore descriptors POP (YCL,XCL,WPTR,PATICL,PATBCL) ENMI2 INCRA PDLPTR,3*DESCR Make room on history list ACOMP PDLPTR,PDLEND,INTR31 * Check for overflow PUTDC PDLPTR,DESCR,DNMICL Insert unravelling function BRANCH ENME3 Join common processing *_ ENMIC SPCINT VVAL,TSP,SCDTER,ENMI3 * Convert STRING to INTEGER *_ ENMEXN PUSH ZEROCL E3.4.4 & E3.5.8 RCALL YPTR,EXPEVL,YPTR,(TSALF,,SCNEMO) E3.4.4 & E3.5.8 POP ZEROCL E3.4.4 & E3.5.8 BRANCH ENMI5 E3.4.4 & E3.5.8 *_ *---------------------------------------------------------------------* * * SUCCEED * SUCE PROC , Matching procedure for SUCCEED SUCE1 INCRA PDLPTR,3*DESCR Make room for history entry ACOMP PDLPTR,PDLEND,INTR31 * Check for overflow PUTDC PDLPTR,DESCR,SUCFCL Insert SUCCESS backup function GETLG TMVAL,TXSP Get length matched PUTDC PDLPTR,2*DESCR,TMVAL * Save on history list PUTDC PDLPTR,3*DESCR,LENFCL * Save current length failure SETAC LENFCL,1 Set length failure BRANIC SCOKCL,0 Return successful match *_ SUCF PROC SUCE SUCCEED failure GETDC XCL,PDLPTR,DESCR Get history entries GETDC YCL,PDLPTR,2*DESCR BRANCH SUCE1 Go in front door *_ *---------------------------------------------------------------------* TITLE 'Defined Functions' * * DEFINE(P,E) * DEFINE PROC , DEFINE(P,E) RCALL XPTR,VARVAL,,FAIL Get prototype PUSH XPTR Save prototype RCALL YPTR,VARVAL,,FAIL Get entry point POP XPTR Restore prototype LOCSP XSP,XPTR Specifier for prototype STREAM YSP,XSP,VARATB,PROTER,PROTER * Break out function name AEQLC STYPE,LPTYP,PROTER Verify open parenthesis RCALL XPTR,GENVAR,(YSPPTR) * Get variable for function name RCALL ZCL,FINDEX,(XPTR) Get function descriptor for function DEQL YPTR,NULVCL,DEFIN3 Check for omitted entry point MOVD YPTR,XPTR If omitted use function name DEFIN3 PUSH YPTR Save entry point MOVD YCL,ZEROCL Set argument count to 0 PUSH XPTR Save function name DEFIN4 FSHRTN XSP,1 Remove break character STREAM YSP,XSP,VARATB,PROTER,PROTER * Break out argument SELBRA STYPE,(PROTER,,DEFIN6) * Check for end LEQLC YSP,0,,DEFIN4 Check for null argument RCALL XPTR,GENVAR,(YSPPTR) * Generate variable for argument PUSH XPTR Save argument INCRA YCL,1 Increment argument count BRANCH DEFIN4 Continue *_ DEFIN6 LEQLC YSP,0,,DEFIN9 INCRA YCL,1 Increment argument count RCALL XPTR,GENVAR,(YSPPTR) * Generate variable for argument PUSH XPTR Save argument DEFIN9 SETVA DEFCL,YCL DEFIN8 FSHRTN XSP,1 STREAM YSP,XSP,VARATB,PROTER,DEF10 * Break out local arguments AEQLC STYPE,CMATYP,PROTER Verify comma LEQLC YSP,0,,DEFIN8 Check for null argument RCALL XPTR,GENVAR,(YSPPTR) * Generate variable PUSH XPTR Save local argument INCRA YCL,1 Increment total count BRANCH DEFIN8 Continue *_ DEF10 LEQLC YSP,0,,DEF11 Check for null argument RCALL XPTR,GENVAR,YSPPTR Generate variable PUSH XPTR Save argument INCRA YCL,1 Increment total count DEF11 INCRA YCL,2 Increment for name and label MULTC XCL,YCL,DESCR Convert to address units SETVC XCL,B Insert block data type RCALL XPTR,BLOCK,XCL Allocate block for definition PUTDC ZCL,0,DEFCL Point to procedure descriptor PUTDC ZCL,DESCR,XPTR Insert definition block SUM XPTR,XPTR,XCL Compute end of block DEF12 DECRA XPTR,DESCR Decrement pointer POP YPTR Restore argument PUTDC XPTR,DESCR,YPTR Insert in definition block DECRA YCL,1 Decrement total count AEQLC YCL,0,DEF12,RETNUL Check for end *_ *---------------------------------------------------------------------* * * Invocation of Defined Function * DEFFNC PROC , Procedure to invoke defined function SETAV XCL,INCL Get number of arguments in call MOVD WCL,XCL Save copy MOVD YCL,INCL Save function descriptor PSTACK YPTR Post stack position PUSH NULVCL Save null value for function name DEFF1 INCRA OCICL,DESCR Increment offset GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,DEFFC Check for function descriptor DEFF2 AEQLC INSW,0,,DEFF14 Check &INPUT LOCAPV ZPTR,INATL,XPTR,DEFF14 * Look for input association GETDC ZPTR,ZPTR,DESCR Get association PUSH (XCL,WCL,YCL,YPTR) Save relevant descriptors RCALL XPTR,PUTIN,(ZPTR,XPTR),FAIL * Perform input POP (YPTR,YCL,WCL,XCL) Restore descriptors BRANCH DEFF3 Join processing *_ DEFF14 GETDC XPTR,XPTR,DESCR Get value DEFF3 PUSH XPTR Save value DECRA XCL,1 Decrement argument count ACOMPC XCL,0,DEFF1,,INTR10 Check for end GETDC XCL,YCL,0 Get expected number of arguments SETAV XCL,XCL Insert in A-field DEFF4 ACOMP WCL,XCL,DEFF9,DEFF5 Compare given and expected PUSH NULVCL Not enough, save null string INCRA WCL,1 Increment count BRANCH DEFF4 Continue *_ DEFF9 POP ZCL Throw away extra argument DECRA WCL,1 Decrement count BRANCH DEFF4 Continue *_ DEFF5 GETDC ZCL,YCL,DESCR Get definition block MOVD XPTR,ZCL Save copy GETSIZ WCL,ZCL Get size of block SUM WPTR,ZCL,WCL Compute pointer to end INCRA XCL,1 Increment for function name DEFF8 INCRA XPTR,DESCR Increment pointer to block INCRA YPTR,DESCR Adjust stack pointer GETDC ZPTR,XPTR,DESCR Get argument name GETDC TPTR,ZPTR,DESCR Get current argument value GETDC ATPTR,YPTR,DESCR Get value from stack PUTDC ZPTR,DESCR,ATPTR Assign to argument name PUTDC YPTR,DESCR,TPTR Put current argument on stack DECRA XCL,1 Decrement count ACOMPC XCL,0,DEFF8,,INTR10 Check for end DEFF10 INCRA XPTR,DESCR Increment pointer to block AEQL XPTR,WPTR,,DEFFGO GETDC ZPTR,XPTR,DESCR Get argument name from block GETDC TPTR,ZPTR,DESCR Get current value of argument PUSH TPTR Save current value PUTDC ZPTR,DESCR,NULVCL Assign null value to local BRANCH DEFF10 Continue *_ DEFFGO PUSH (FRTNCL,STNOCL,OCICL,OCBSCL,ZCL,ZCL) * Save system state GETDC XCL,ZCL,DESCR Get entry label AEQLIC XCL,ATTRIB,0,,UNDFFE E3.0.2 GETDC OCBSCL,XCL,ATTRIB E3.0.2 ACOMPC TRACL,0,,DEFF18,DEFF18 * Check &FTRACE DECRA TRACL,1 Decrement &FTRACE GETDC ATPTR,ZCL,2*DESCR Get function name PUSH ZCL Save definition block RCALL ,FENTR2,(ATPTR),(INTR10,INTR10) * Perform function trace POP ZCL Restore definition block DEFF18 ACOMPC TRAPCL,0,,DEFF19,DEFF19 * Check &TRACE GETDC ATPTR,ZCL,2*DESCR Get function name LOCAPT ATPTR,TFENTL,ATPTR,DEFF19 * Check for CALL trace PUSH (OCBSCL,ZCL) Save object code base and block RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace POP (ZCL,OCBSCL) Restore base and block DEFF19 INCRA LVLCL,1 Increment &FNCLEVEL ACOMPC TRAPCL,0,,DEFF15,DEFF15 * Check &TRACE LOCAPT ATPTR,TKEYL,FNCLKY,DEFF15 * Look for KEYWORD trace RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace DEFF15 SETAC OCICL,0 Zero offset RCALL ,INTERP,,(DEFFF,DEFFNR) * Call interpreter MOVD RETPCL,RETCL Set &RTNTYPE to RETURN DEFFS1 POP ZCL Restore definition block ACOMPC TRACL,0,,DEFF20,DEFF20 * Check &FTRACE DECRA TRACL,1 Decrement &FTRACE GETDC ATPTR,ZCL,2*DESCR Get function name PUSH ZCL Save definition block RCALL ,FNEXT2,(ATPTR),(INTR10,INTR10) * Perform function trace POP ZCL Restore definition block DEFF20 ACOMPC TRAPCL,0,,DEFFS2,DEFFS2 * Check &TRACE GETDC ATPTR,ZCL,2*DESCR Get function name LOCAPT ATPTR,TFEXTL,ATPTR,DEFFS2 * Check for RETURN trace PUSH (RETPCL,ZCL) Save return and block RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace POP (ZCL,RETPCL) Restore block and return DEFFS2 DECRA LVLCL,1 Decrement &FNCLEVEL ACOMPC TRAPCL,0,,DEFF17,DEFF17 * Check &TRACE LOCAPT ATPTR,TKEYL,FNCLKY,DEFF17 * Check for KEYWORD trace PUSH (RETPCL,ZCL) Save return and block RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace POP (ZCL,RETPCL) Restore block and return DEFF17 POP (ZCL,OCBSCL,OCICL,STNOCL,FRTNCL) * Restore system state GETSIZ WCL,ZCL Get size of definition block DECRA WCL,DESCR Decrement pointer ACOMPC WCL,0,,INTR10,INTR10 * Check for end SUM WPTR,ZCL,WCL Compute pointer to last descriptor MOVD YPTR,ZCL Save pointer to block INCRA YPTR,DESCR Increment pointer GETDC ZPTR,YPTR,DESCR Get function name GETDC ZPTR,ZPTR,DESCR Get value to be returned DEFF6 POP XPTR Get old value GETDC YPTR,WPTR,DESCR Get argument name PUTDC YPTR,DESCR,XPTR Restore old value DECRA WPTR,DESCR Decrement pointer AEQL WPTR,ZCL,DEFF6 Check for end DEQL RETPCL,FRETCL,,FAIL Check for FRETURN DEQL RETPCL,NRETCL,RTZPTR * Check for NRETURN MOVD XPTR,ZPTR Move name to correct descriptor VEQLC XPTR,S,,DEFFVX Check for natural variable VEQLC XPTR,I,,GENVIX Convert integer VEQLC XPTR,N,,RTXNAM Check for created variable VEQLC XPTR,K,NONAME,RTXNAM * Check for keyword variable DEFFVX AEQLC XPTR,0,RTXNAM,NONAME * Check for null string *_ DEFFF MOVD RETPCL,FRETCL Set up FRETURN BRANCH DEFFS1 Join processing *_ DEFFC PUSH (XCL,WCL,YCL,YPTR) Save relevant descriptors RCALL XPTR,INVOKE,(XPTR),(FAIL,DEFFN) * Evaluate argument POP (YPTR,YCL,WCL,XCL) Restore relevant variables BRANCH DEFF3 Join processing *_ DEFFN POP (YPTR,YCL,WCL,XCL) Restore relevant variables BRANCH DEFF2 Join processing *_ DEFFNR MOVD RETPCL,NRETCL Set up NRETURN BRANCH DEFFS1 Join processing *_ *---------------------------------------------------------------------* TITLE 'External Functions' * * LOAD(P) * LOAD PROC , LOAD(P) RCALL XPTR,VARVAL,,FAIL Get prototype PUSH XPTR Save prototype RCALL WPTR,VARVAL,,FAIL Get library name LOCSP VSP,WPTR Get specifier for library POP XPTR Restore prototypr LOCSP XSP,XPTR Get specifier for prototype STREAM YSP,XSP,VARATB,PROTER,PROTER * Get function name from prototype AEQLC STYPE,LPTYP,PROTER Verify left parenthesis RCALL XPTR,GENVAR,YSPPTR Generate variable for function RCALL ZCL,FINDEX,XPTR Find function MOVD YCL,ZEROCL Set argument count to zero LOAD4 FSHRTN XSP,1 Remove break character STREAM ZSP,XSP,VARATB,LOAD1,PROTER * Break out argument SELBRA STYPE,(PROTER,,LOAD6) * Branch on break type RCALL XPTR,GENVAR,ZSPPTR Generate variable for data type LOCAPV XPTR,DTATL,XPTR,LOAD9 * Look up data type GETDC XPTR,XPTR,DESCR Extract data type code PUSH XPTR Save data type code LOAD10 INCRA YCL,1 Increment count of arguments BRANCH LOAD4 Continue *_ LOAD6 INCRA YCL,1 Count last argument RCALL XPTR,GENVAR,ZSPPTR Generate variable for data type LOCAPV XPTR,DTATL,XPTR,LOAD11 * Look up data type GETDC XPTR,XPTR,DESCR Get data type code PUSH XPTR Save data type code LOAD13 FSHRTN XSP,1 Delete right parenthesis RCALL XPTR,GENVAR,XSPPTR Generate variable for target LOCAPV XPTR,DTATL,XPTR,LOAD7 * Look up data type GETDC XPTR,XPTR,DESCR Get data type code PUSH XPTR Save data type code LOAD8 SETVA LODCL,YCL Insert number of arguments INCRA YCL,1 Increment count MULTC XCL,YCL,DESCR Convert to address units INCRA XCL,DESCR Add space for entry point SETVC XCL,B Insert BLOCK data type RCALL XPTR,BLOCK,XCL Allocate block for definition PUTDC ZCL,0,LODCL Insert procedure descriptor PUTDC ZCL,DESCR,XPTR Insert definition block SUM XPTR,XPTR,XCL Compute pointer to end of block LOAD12 DECRA XPTR,DESCR Decrement pointer POP YPTR Restore data type PUTDC XPTR,DESCR,YPTR Insert in block DECRA YCL,1 Decrement count ACOMPC YCL,0,LOAD12 Check for end LOAD YPTR,YSP,VSP,FAIL Load external function PUTDC XPTR,0,YPTR Insert entry point BRANCH RETNUL Return null string as value *_ LOAD7 PUSH ZEROCL Save 0 for unspecified type BRANCH LOAD8 Continue *_ LOAD9 PUSH ZEROCL Save 0 for unspecified type BRANCH LOAD10 Continue *_ LOAD1 PUSH ZEROCL Save 0 for unspecified type SETSP TSP,XSP Set up break check SETLC TSP,1 Set length to 1 INCRA YCL,1 LEXCMP TSP,RPRNSP,LOAD4,LOAD13,LOAD4 *_ LOAD11 PUSH ZEROCL Save 0 for unspecified type BRANCH LOAD13 Continue *_ *---------------------------------------------------------------------* * * UNLOAD(F) * UNLOAD PROC , UNLOAD(F) RCALL XPTR,VARVAL,,FAIL Get function name RCALL ZCL,FINDEX,XPTR Locate function descriptor PUTDC ZCL,0,UNDFCL Undefine function LOCSP XSP,XPTR Get specifier UNLOAD XSP Unload external definition BRANCH RETNUL Return *_ *---------------------------------------------------------------------* * * Linkage to External Functions * LNKFNC PROC , Procedure to link to externals SETAV XCL,INCL Get actual number of arguments MOVD YCL,INCL Save function descriptor SETAV WCL,YCL E3.9.1 GETDC ZCL,YCL,DESCR Get definition block PSTACK YPTR Post stack position SETAC TCL,2*DESCR Set offset for first argument LNKF1 PUSH (XCL,ZCL,TCL,YPTR,WCL,YCL) * Save working descriptors RCALL XPTR,ARGVAL,,FAIL Evaluate argument POP (YCL,WCL,YPTR,TCL,ZCL,XCL) * Restore working descriptors DECRA WCL,1 E3.9.1 ACOMPC WCL,0,,,LNKF8 E3.9.1 LNKF7 GETD ZPTR,ZCL,TCL Get data type required VEQLC ZPTR,0,,LNKF6 Check for possible conversion VEQL ZPTR,XPTR,,LNKF6 Skip if data types the same SETAV DTCL,XPTR Data type of argument MOVV DTCL,ZPTR Data type required DEQL DTCL,VIDTP,,LNKVI STRING-INTEGER DEQL DTCL,IVDTP,,LNKIV INTEGER-STRING DEQL DTCL,RIDTP,,LNKRI REAL-INTEGER DEQL DTCL,IRDTP,,LNKIR INTEGER-REAL DEQL DTCL,RVDTP,,LNKRV REAL-STRING DEQL DTCL,VRDTP,INTR1,LNKVR * STRING-REAL LNKIV RCALL XPTR,GNVARI,XPTR,LNKF6 * Convert INTEGER to STRING *_ LNKRI RLINT XPTR,XPTR,INTR1,LNKF6 * Convert REAL to INTEGER *_ LNKIR INTRL XPTR,XPTR Convert INTEGER to REAL BRANCH LNKF6 *_ LNKVR LOCSP XSP,XPTR Get specifier SPCINT XPTR,XSP,,LNKIR Convert STRING to INTEGER SPREAL XPTR,XSP,INTR1,LNKF6 * Convert STRING to REAL *_ LNKRV REALST XSP,XPTR RCALL XPTR,GENVAR,XSPPTR,LNKF6 *_ LNKVI LOCSP XSP,XPTR Get specifier SPCINT XPTR,XSP,,LNKF6 Convert to INTEGER SPREAL XPTR,XSP,INTR1,LNKRI * Convert STRING to REAL LNKF6 INCRA TCL,DESCR Increment offset PUSH XPTR Save argument LNKF8 DECRA XCL,1 E3.9.1 ACOMPC XCL,0,LNKF1 E3.9.1 GETDC WPTR,YCL,0 Get procedure descriptor SETAV WPTR,WPTR Get argument count required LNKF4 ACOMPC WCL,0,,LNKF5,LNKF5 E3.9.1 PUSH NULVCL E3.9.1 DECRA WCL,1 Decrement argument count BRANCH LNKF4 Continue *_ LNKF5 GETSIZ WCL,ZCL Get size of definition block SUM XPTR,ZCL,WCL Compute pointer to end GETDC ZPTR,XPTR,0 Get data target descriptor GETDC ZCL,ZCL,DESCR Get function address INCRA YPTR,2*DESCR Get pointer to argument list LINK ZPTR,YPTR,WPTR,ZCL,FAIL * Link to external function VEQLC ZPTR,L,RTZPTR Check for linked string GETSPC ZSP,ZPTR,0 Get specifier BRANCH GENVRZ Go generate variable *_ *---------------------------------------------------------------------* TITLE 'Arrays, Tables, and Defined Data Objects' * * ARRAY(P,V) * ARRAY PROC , ARRAY(P,V) RCALL XPTR,VARVAL,,FAIL Get prototype PUSH XPTR Save prototype RCALL TPTR,ARGVAL,,FAIL Get initial value for array elements POP XPTR Restore prototype SETAC ARRMRK,0 Clear prototype analysis switch MOVD WCL,ZEROCL Initialize dimensionality to zero MOVD XCL,ONECL Initialize size to one LOCSP XSP,XPTR Get specifier to prototype PUSH XPTR Save prototype for later insertion ARRAY1 STREAM YSP,XSP,NUMBTB,PROTER,ARROT1 E3.5.1 SPCINT YCL,YSP,PROTER Convert string to integer SELBRA STYPE,(,ARRAY3) Branch on colon or comma FSHRTN XSP,1 Delete colon STREAM ZSP,XSP,NUMBTB,PROTER,ARROT2 SPCINT ZCL,ZSP,PROTER Convert upper bound to integer SELBRA STYPE,(PROTER,ARRAY5) * Verify break character *_ ARRAY3 ACOMPC YCL,0,,PROTER,PROTER * Single number must be positive MOVD ZCL,YCL Move to copy SETAC YCL,1 Set lower bound to default of one BRANCH ARRAY6 *_ ARRAY5 SUBTRT ZCL,ZCL,YCL Compute difference SUM ZCL,ZCL,ONECL Add one ACOMPC ZCL,0,,,PROTER ARRAY6 SETVA YCL,ZCL Insert width of dimension PUSH YCL Save dimension information MULT XCL,XCL,ZCL,PROTER Compute size of array to this point INCRA WCL,1 Increase count of dimensions AEQLC ARRMRK,0,ARRAY7 E3.5.1 FSHRTN XSP,1 Remove break character BRANCH ARRAY1 *_ ARROT1 SETAC ARRMRK,1 On run out, mark end of prototype SPCINT YCL,YSP,PROTER,ARRAY3 * Convert string to integer *_ ARROT2 SETAC ARRMRK,1 On run out, mark end of prototype SPCINT ZCL,ZSP,PROTER,ARRAY5 * Convert string to integer *_ ARRAY7 SUM ZCL,XCL,WCL Add dimensionality to array size INCRA ZCL,2 Add two for heading information MULTC ZCL,ZCL,DESCR Convert to address units SETVC ZCL,A Insert ARRAY data type RCALL ZPTR,BLOCK,ZCL Allocate block for array structure MOVD XPTR,ZPTR Save copy SUM WPTR,XPTR,ZCL Get pointer to last descriptor PUTDC ZPTR,2*DESCR,WCL Insert dimensionality INCRA XPTR,DESCR Update working pointer ARRAY8 INCRA XPTR,DESCR Update working pointer for another POP YPTR Restore index pair PUTDC XPTR,DESCR,YPTR Insert in structure DECRA WCL,1 Decrement dimensionality ACOMPC WCL,0,ARRAY8,ARRFIL Check for last one ARRAY9 PUTDC XPTR,DESCR,TPTR Insert initial value ARRFIL INCRA XPTR,DESCR Update working pointer ACOMP XPTR,WPTR,INTR10,,ARRAY9 * Check for end POP WPTR RESTORE PROTOTYPE E3.10.1 PUTDC ZPTR,DESCR,WPTR RETURN POINTER TO ARRAY E3.10.1 BRANCH RTZPTR Return pointer to array structure *_ *---------------------------------------------------------------------* * * TABLE(N,M) * ASSOC PROC , TABLE(N,M) RCALL XPTR,INTVAL,,FAIL Get table size PUSH XPTR Save size RCALL WPTR,INTVAL,,FAIL Get secondary allocation MULT ZPTR,WPTR,DSCRTW,SIZERR E3.10.4 INCRA ZPTR,2*DESCR E3.10.4 ACOMP ZPTR,SIZLMT,SIZERR,SIZERR E3.10.4 POP XPTR Restore size ACOMPC XPTR,0,ASSOC1,,LENERR SETAC XPTR,EXTSIZ ASSOC1 INCRA XPTR,1 E3.2.3 MULTC XPTR,XPTR,2*DESCR E3.2.3 ACOMPC WPTR,0,ASSOC4,,LENERR SETAC WPTR,EXTSIZ ASSOC4 INCRA WPTR,1 E3.2.3 MULTC WPTR,WPTR,2*DESCR E3.2.3 SETVC XPTR,T E3.2.3 ASSOCE PROC ASSOC E3.2.3 RCALL ZPTR,BLOCK,XPTR E3.2.3 PUTD ZPTR,XPTR,ONECL E3.2.3 DECRA XPTR,DESCR E3.2.3 PUTD ZPTR,XPTR,WPTR E3.2.3 ASSOC2 DECRA XPTR,2*DESCR E3.2.3 PUTD ZPTR,XPTR,NULVCL E3.2.3 AEQLC XPTR,DESCR,ASSOC2,RTZPTR E3.2.3 *_ *---------------------------------------------------------------------* * * DATA(P) * DATDEF PROC , DATA(P) RCALL XPTR,VARVAL,,FAIL Get prototype SETAC DATACL,0 Initialize prototype switch LOCSP XSP,XPTR Get specifier STREAM YSP,XSP,VARATB,PROTER,PROTER * Break out data type name AEQLC STYPE,LPTYP,PROTER Verify left parenthesis RCALL XPTR,GENVAR,(YSPPTR) * Generate variable for name RCALL ZCL,FINDEX,(XPTR) Find function descriptor INCRV DATSEG,1 Increment data type code VEQLC DATSEG,DATSIZ,,INTR27 * Check against limit MOVD YCL,ZEROCL Initialize count of fields RCALL DTATL,AUGATL,(DTATL,DATSEG,XPTR) * Augment data type pair list PSTACK WPTR Post stack position PUSH (DATSEG,XPTR) Save code and name DATA3 FSHRTN XSP,1 Delete break character AEQLC DATACL,0,DAT5 Check for prototype end STREAM YSP,XSP,VARATB,PROTER,PROTER * Break out field SELBRA STYPE,(PROTER,,DATA6) DATA4 LEQLC YSP,0,,DATA3 Check for zero length RCALL XPTR,GENVAR,YSPPTR Generate variable PUSH XPTR Save field name RCALL XCL,FINDEX,(XPTR) Find function descriptor for field GETDC WCL,XCL,0 Get procedure descriptor DEQL WCL,FLDCL,DAT6 Check for FIELD procedure GETDC ZPTR,XCL,DESCR Get field definition block MULTC TCL,YCL,DESCR RCALL ZPTR,AUGATL,(ZPTR,DATSEG,TCL) DAT7 PUTDC XCL,DESCR,ZPTR Insert new definition block INCRA YCL,1 BRANCH DATA3 Continue *_ DATA6 SETAC DATACL,1 Note end of prototype analysis BRANCH DATA4 Join field processing *_ DAT5 LEQLC XSP,0,PROTER Verify prototype consumption AEQLC YCL,0,,PROTER E3.1.2 SETVA DATCL,YCL Insert field count for data function PUTDC ZCL,0,DATCL Insert new procedure descriptor MULTC YCL,YCL,DESCR INCRA YCL,2*DESCR Add two for the number and name MOVV YCL,DATSEG Insert defined data code RCALL ZPTR,BLOCK,YCL Allocate definition block INCRA WPTR,DESCR E3.0.3 MOVBLK ZPTR,WPTR,YCL Copy from stack into block PUTDC ZCL,DESCR,ZPTR Insert definition block BRANCH RETNUL Return null value *_ DAT6 PUTDC XCL,0,FLDCL Insert FIELD procedure descriptor RCALL ZPTR,BLOCK,TWOCL Allocate definition block PUTDC ZPTR,DESCR,DATSEG Insert data type code MULTC TCL,YCL,DESCR PUTDC ZPTR,2*DESCR,TCL BRANCH DAT7 Join processing *_ *---------------------------------------------------------------------* * * PROTOTYPE(A) * PROTO PROC , PROTOTYPE(A) RCALL XPTR,ARGVAL,,FAIL Get argument VEQLC XPTR,A,NONARY Verify ARRAY GETDC ZPTR,XPTR,DESCR Get prototype BRANCH RTZPTR Return *_ *---------------------------------------------------------------------* * * Array and Table References * ITEM PROC , Array or table reference SETAV XCL,INCL Get argument count DECRA XCL,1 Skip referenced object PUSH XCL Save count RCALL YCL,ARGVAL,,FAIL Get referenced object POP XCL Restore count VEQLC YCL,A,,ARYAD3 ARRAY is acceptable VEQLC YCL,T,NONARY,ASSCR TABLE is acceptable ARYAD3 MOVD WCL,XCL Save copy of argument count ARYAD1 ACOMPC XCL,0,,ARYAD2,ARYAD2 * Count down on arguments PUSH (XCL,WCL,YCL) Save RCALL XPTR,INTVAL,,FAIL Get index POP (YCL,WCL,XCL) Restore saved descriptors PUSH XPTR Save index DECRA XCL,1 Decrement argument count BRANCH ARYAD1 *_ ARYAD2 MOVD ZPTR,ZEROCL Initialize offset to zero GETDC ZCL,YCL,2*DESCR Get number of dimensions MULTC YPTR,ZCL,DESCR Convert to addressing units SUM YPTR,YCL,YPTR Add base and offset INCRA YPTR,2*DESCR Add two for heading ARYAD7 ACOMP WCL,ZCL,ARGNER,ARYAD9 * Compare given and required number PUSH ZEROCL If too few, supply a zero INCRA WCL,1 Increment and loop BRANCH ARYAD7 *_ ARYAD9 INCRA YCL,2*DESCR GETDC WPTR,YCL,DESCR Get index pair SETAV TPTR,WPTR Get extent of dimension ARYA11 POP XPTR Get index value SUBTRT XPTR,XPTR,WPTR Compute differnece from lower bound ACOMPC XPTR,0,,,FAIL If less than zero, out of bounds ACOMP XPTR,TPTR,FAIL,FAIL If greater than extent, out of bound SUM XPTR,ZPTR,XPTR Else add to evolving sum DECRA ZCL,1 Decrement dimension count ACOMPC ZCL,0,,ARYA12 Get out if done INCRA YCL,DESCR Adjust bas pointer GETDC WPTR,YCL,DESCR Get index pair SETAV TPTR,WPTR Get extent of dimension MULT ZPTR,XPTR,TPTR Multiply for next dimension BRANCH ARYA11 Continue with next dimension *_ ARYA12 MULTC XPTR,XPTR,DESCR Expand offset into addressing units SUM XPTR,YPTR,XPTR Add to adjusted base ARYA10 SETVC XPTR,N Insert NAME data type BRANCH RTXNAM Return interior pointer *_ ASSCR AEQLC XCL,1,ARGNER Only one argument for tables PUSH YCL Save pointer to object RCALL YPTR,ARGVAL,,FAIL Evaluate argument POP XPTR E3.2.3 ASSCR5 LOCAPV WPTR,XPTR,YPTR,,ASSCR4 E3.2.3 LOCAPV WPTR,XPTR,ZEROCL,ASSCR2 * Look for item with null value ASSCR4 MOVA XPTR,WPTR PUTDC XPTR,2*DESCR,YPTR E3.2.3 BRANCH ARYA10 Join array reference exit *_ ASSCR2 GETSIZ TCL,XPTR E3.2.3 GETD ZPTR,XPTR,TCL E3.2.3 AEQLC ZPTR,1,,ASSCR3 E3.2.3 MOVD XPTR,ZPTR E3.2.3 BRANCH ASSCR5 E3.2.3 *_ E3.2.3 ASSCR3 DECRA TCL,DESCR E3.2.3 GETD WPTR,XPTR,TCL E3.2.3 PUSH (XPTR,TCL,YPTR) E3.2.3 MOVD XPTR,WPTR E3.2.3 RCALL ZPTR,ASSOCE,,(INTR10,INTR10) E3.2.3 POP (YPTR,TCL,XPTR) E3.2.3 SETVC ZPTR,B E3.2.3 INCRA TCL,DESCR E3.2.3 PUTD XPTR,TCL,ZPTR E3.2.3 PUTDC ZPTR,2*DESCR,YPTR E3.2.3 MOVD XPTR,ZPTR E3.2.3 BRANCH ARYA10 E3.2.3 *_ *---------------------------------------------------------------------* * Defined Object Creation * DEFDAT PROC , Procedure to create defined objects SETAV XCL,INCL Get given number of arguments MOVD WCL,XCL Save a copy MOVD YCL,INCL Save function descriptor PSTACK YPTR Post stack position DEFD1 INCRA OCICL,DESCR Increment offset GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,DEFDC Check for function DEFD2 AEQLC INSW,0,,DEFD8 Check &INPUT LOCAPV ZPTR,INATL,XPTR,DEFD8 * Look for input association GETDC ZPTR,ZPTR,DESCR Get association PUSH (XCL,WCL,YCL,YPTR) Save relevant descriptors RCALL XPTR,PUTIN,(ZPTR,XPTR),FAIL POP (YPTR,YCL,WCL,XCL) Restore relevant descriptors BRANCH DEFD3 Join main processing *_ DEFD8 GETDC XPTR,XPTR,DESCR Get value DEFD3 PUSH XPTR Save value DECRA XCL,1 Decrement argument count ACOMPC XCL,0,DEFD1,,INTR10 Check for end GETDC XCL,YCL,0 Get procedure descriptor SETAV XCL,XCL Get number of arguments expected DEFD4 ACOMP WCL,XCL,DEFD5,DEFD5 Compare given with expected PUSH NULVCL Save null for omitted argument INCRA WCL,1 Increment count BRANCH DEFD4 Continue *_ DEFD5 GETDC WCL,YCL,DESCR Get definition block MULTC XCL,XCL,DESCR MOVV XCL,WCL Insert data type code RCALL ZPTR,BLOCK,XCL Allocate block for data object INCRA YPTR,DESCR Adjust stack position MOVBLK ZPTR,YPTR,XCL Move values into block BRANCH RTZPTR Return new object *_ DEFDC PUSH (XCL,WCL,YCL,YPTR) Save relevant descriptors RCALL XPTR,INVOKE,(XPTR),(FAIL,DEFDN) POP (YPTR,YCL,WCL,XCL) Restore relevant descriptors BRANCH DEFD3 Join main processing *_ DEFDN POP (YPTR,YCL,WCL,XCL) Restore relevant descriptors BRANCH DEFD2 Join main processing *_ *---------------------------------------------------------------------* * * Fields of Defined Data Objects * FIELD PROC , Field function procedure PUSH INCL Save function descriptor RCALL XPTR,ARGVAL,,FAIL Get value DEQL XPTR,NULVCL,,NONAME Check for null value POP YCL Restore function descriptor VEQLC XPTR,I,FIELD1 Check for INTEGER RCALL XPTR,GNVARI,XPTR Convert INTEGER to STRING FIELD1 MOVV DT1CL,XPTR Set up data type GETDC YPTR,YCL,DESCR Get definition block LOCAPT ZCL,YPTR,DT1CL,INTR1 * Look for data type offset GETDC ZCL,ZCL,2*DESCR Get offset SUM XPTR,XPTR,ZCL Compute field position SETVC XPTR,N Insert NAME data type BRANCH RTXNAM Return name *_ *---------------------------------------------------------------------* TITLE 'Input and Output' * * INPUT(V,U,L) * READ PROC , INPUT(V,U,L) RCALL XPTR,IND,,FAIL Get variable PUSH XPTR Save variable RCALL YPTR,INTVAL,,FAIL Get unit PUSH YPTR Save unit RCALL ZPTR,INTVAL,,FAIL Get length POP (YPTR,XPTR) Restore unit and variable ACOMPC YPTR,0,,READ5,UNTERR * Check for defaulted unit READ6 ACOMPC ZPTR,0,READ2,,LENERR * Check for defaulted length LOCAPT TPTR,INSATL,YPTR,READ4 * Look for default length READ3 LOCAPV ZPTR,INATL,XPTR,READ1 * Look for existing association PUTDC ZPTR,DESCR,TPTR Inset input block BRANCH RETNUL Return *_ Add new association pair READ1 RCALL INATL,AUGATL,(INATL,TPTR,XPTR),RETNUL *_ READ4 MOVD ZPTR,DFLSIZ Set standard default READ2 RCALL TPTR,BLOCK,IOBLSZ Allocate block PUTDC TPTR,DESCR,YPTR Insert unit PUTDC TPTR,2*DESCR,ZPTR Insert format BRANCH READ3 Rejoin processing *_ READ5 SETAC YPTR,UNITI Set up default unit BRANCH READ6 Join processing *_ *---------------------------------------------------------------------* * * OUTPUT(V,U,F) * PRINT PROC , OUTPUT(V,U,F) RCALL XPTR,IND,,FAIL Get variable PUSH XPTR Save variable RCALL YPTR,INTVAL,,FAIL Get unit PUSH YPTR Save unit RCALL ZPTR,VARVAL,,FAIL Get format POP (YPTR,XPTR) Restore unit and variable ACOMPC YPTR,0,,PRINT5,UNTERR PRINT6 AEQLC ZPTR,0,PRINT2 Check for defaulted format LOCAPT TPTR,OTSATL,YPTR,PRINT4 * Insert length PRINT3 LOCAPV ZPTR,OUTATL,XPTR,PRINT1 * Look for output association PUTDC ZPTR,DESCR,TPTR Insert output block BRANCH RETNUL Return *_ PRINT1 RCALL OUTATL,AUGATL,(OUTATL,TPTR,XPTR),RETNUL * Add new association pair *_ PRINT4 MOVD ZPTR,DFLFST Set up standard default PRINT2 RCALL TPTR,BLOCK,IOBLSZ Allocate block PUTDC TPTR,DESCR,YPTR Insert unit PUTDC TPTR,2*DESCR,ZPTR Insert format BRANCH PRINT3 Rejoin processing *_ PRINT5 SETAC YPTR,UNITO Set default unit BRANCH PRINT6 Join processing *_ *---------------------------------------------------------------------* * * BACKSPACE(U), ENDFILE(U), and REWIND(U) * BKSPCE PROC , BACKSPACE(N) SETAC SCL,1 Indicate backspace BRANCH IOOP *_ ENFILE PROC BKSPCE ENDFILE(N) SETAC SCL,2 Indicate end of file BRANCH IOOP *_ REWIND PROC BKSPCE REWIND(N) SETAC SCL,3 Indicate rewind IOOP PUSH SCL Push indicator RCALL XCL,INTVAL,,FAIL Evaluate integer argument ACOMPC XCL,0,,UNTERR,UNTERR * Reject negative or zero POP SCL Restore indicator SELBRA SCL,(,EOP,ROP) Select operation BKSPCE XCL Backspace unit BRANCH RETNUL *_ EOP ENFILE XCL End file unit BRANCH RETNUL *_ ROP REWIND XCL Rewind unit BRANCH RETNUL *_ *---------------------------------------------------------------------* * * DETACH(N) * DETACH PROC , DETACH(N) RCALL XPTR,IND,,FAIL Get name of variable LOCAPV ZPTR,INATL,XPTR,DTCH1 * Look for input association PUTDC ZPTR,DESCR,ZEROCL Delete association if there is one PUTDC ZPTR,2*DESCR,ZEROCL Clear association pointer also DTCH1 LOCAPV ZPTR,OUTATL,XPTR,RETNUL * Look for output association PUTDC ZPTR,DESCR,ZEROCL Delete association is there is one PUTDC ZPTR,2*DESCR,ZEROCL Clear association pointer also BRANCH RETNUL Return null value *_ *---------------------------------------------------------------------* * * Input Procedure * PUTIN PROC , Input procedure POP (IO1PTR,IO2PTR) Restore block and variable GETDC IO3PTR,IO1PTR,DESCR Get unit GETDC IO1PTR,IO1PTR,2*DESCR * Get length RCALL IO4PTR,CONVAR,(IO1PTR) * Get space for string LOCSP IOSP,IO4PTR Get specifier INCRA RSTAT,1 Increment count of reads STREAD IOSP,IO3PTR,FAIL,COMP5 * Perform read AEQLC TRIMCL,0,,PUTIN1 Check &INPUT TRIMSP IOSP,IOSP Trim string GETLG IO1PTR,IOSP Get length PUTIN1 ACOMP IO1PTR,MLENCL,INTR8 E3.9.2 VEQLC IO2PTR,K,,PUTIN3 CHECK FOR KEYWORD E3.10.2 RCALL IO1PTR,GNVARS,IO1PTR E3.9.2 * Form variable for string PUTIN2 PUTDC IO2PTR,DESCR,IO1PTR E3.10.2 RRTURN IO1PTR,2 Return value PUTIN3 LOCSP XSP,IO1PTR E3.10.2 SPCINT IO1PTR,XSP,INTR1,PUTIN2 E3.10.2 *_ *---------------------------------------------------------------------* * * Output Procedure * PUTOUT PROC , Output procedure POP (IO1PTR,IO2PTR) Restore block and value VEQLC IO2PTR,S,,PUTV Is value STRING? VEQLC IO2PTR,I,,PUTI Is value INTEGER? RCALL IO2PTR,DTREP,IO2PTR Get data type representation GETSPC IOSP,IO2PTR,0 Get specifier BRANCH PUTVU Join processing *_ PUTV LOCSP IOSP,IO2PTR Get specifier PUTVU STPRNT IOKEY,IO1PTR,IOSP Perform print INCRA WSTAT,1 Increment count of writes BRANCH RTN1 Return *_ PUTI INTSPC IOSP,IO2PTR Convert INTEGER to STRING BRANCH PUTVU Rejoin processing *_ *---------------------------------------------------------------------* TITLE 'Tracing Procedures and Functions' * * TRACE(V,R,T,F) * TRACE PROC , TRACE(V,R,T,F) RCALL XPTR,IND,,FAIL Get name of variable PUSH XPTR Save name RCALL YPTR,VARVAL,,FAIL Get trace type PUSH YPTR Save type RCALL WPTR,ARGVAL,,FAIL Get tag PUSH WPTR Save tag RCALL ZPTR,VARVAL,,FAIL Get trace function POP (WPTR,YPTR,XPTR) Restore saved arguments DEQL YPTR,NULVCL,TRAC5 Is type defaulted?? MOVD YPTR,VALTRS Set up VALUE default TRAC5 LOCAPV YPTR,TRATL,YPTR,TRAC1 * Look for trace type GETDC YPTR,YPTR,DESCR Get sub pair list TRACEP PROC TRACE Subentry for TRACE GETDC TPTR,YPTR,DESCR Get default function DEQL ZPTR,NULVCL,,TRAC2 Check for null RCALL TPTR,FINDEX,(ZPTR) Locate function descriptor TRAC2 SETAC XSIZ,5*DESCR V3.7 SETVC XSIZ,C Insert CODE data type RCALL XCL,BLOCK,XSIZ Allocate block for code MOVBLK XCL,TRCBLK,XSIZ V3.7 SETVC TPTR,2 Set up 2 arguments PUTDC XCL,1*DESCR,TPTR Insert function descriptor PUTDC XCL,3*DESCR,XPTR Insert name to be traced PUTDC XCL,5*DESCR,WPTR Insert tag GETDC TPTR,YPTR,0 Make entry for proper attribute AEQLC TPTR,0,,TRAC4 LOCAPT TPTR,TPTR,XPTR,TRAC3 * Locate trace PUTDC TPTR,2*DESCR,XCL Insert new code block BRANCH RETNUL Return *_ TRAC3 RCALL TPTR,AUGATL,(TPTR,XPTR,XCL) * Augment pair list for new entry TRAC6 PUTDC YPTR,0,TPTR Link in new pair list BRANCH RETNUL Return *_ TRAC1 DEQL YPTR,FUNTCL,INTR30 Is type FUNCTION? MOVD YPTR,TFNCLP Set up CALL trace RCALL ,TRACEP,,(INTR10,INTR10) * Call subentry to do it MOVD YPTR,TFNRLP Set up RETURN trace BRANCH TRACEP Branch to subentry to do it *_ TRAC4 RCALL TPTR,BLOCK,TWOCL Allocate new pair list PUTDC TPTR,DESCR,XPTR Insert name to be traced PUTDC TPTR,2*DESCR,XCL Insert pointer to pseudo-code BRANCH TRAC6 *_ *---------------------------------------------------------------------* * * STOPTR(N,T) * STOPTR PROC , STOPTR(T,R) RCALL XPTR,IND,,FAIL Get name of variable PUSH XPTR Save name RCALL YPTR,VARVAL,,FAIL Get trace respect POP XPTR DEQL YPTR,NULVCL,STOPT2 Check for defaulted respect MOVD YPTR,VALTRS Set up VALUE as default STOPT2 LOCAPV YPTR,TRATL,YPTR,STOPT1 * Look for trace respect GETDC YPTR,YPTR,DESCR Get pointer to trace list STOPTP PROC STOPTR Subentry for FUNCTION GETDC YPTR,YPTR,0 Get trace list LOCAPT YPTR,YPTR,XPTR,FAIL Look for traced variable PUTDC YPTR,DESCR,ZEROCL Zero the entry PUTDC YPTR,2*DESCR,ZEROCL Overwrite trace BRANCH RETNUL Return *_ STOPT1 DEQL YPTR,FUNTCL,INTR30 Check for FUNCTION MOVD YPTR,TFNCLP Set up CALL RCALL ,STOPTP,,(FAIL,INTR10) * Call subprocedure MOVD YPTR,TFNRLP Set up RETURN BRANCH STOPTP Branch to subentry *_ *---------------------------------------------------------------------* * * Call Tracing * FENTR PROC , Procedure to trace on CALL RCALL WPTR,VARVAL,,FAIL Get argument FENTR3 SETLC PROTSP,0 Clear specifier APDSP PROTSP,TRSTSP Append trace message INTSPC XSP,STNOCL Convert &STNO to string APDSP PROTSP,XSP Append &STNO APDSP PROTSP,COLSP Append colon APDSP PROTSP,TRLVSP Append level message INTSPC XSP,LVLCL Convert &FNCLEVEL to string APDSP PROTSP,XSP Append &FNCLEVEL APDSP PROTSP,TRCLSP Append call message LOCSP XSP,WPTR Get specifier for argument GETLG TCL,XSP Get length ACOMPC TCL,BUFLEN,FXOVR,FXOVR * Check for excessively long string APDSP PROTSP,XSP Append function name APDSP PROTSP,LPRNSP Append left parenthesis SETAC WCL,0 Set argument count to 0 FNTRLP INCRA WCL,1 Increment argument count RCALL ZPTR,ARGINT,(WPTR,WCL),(FENTR4,INTR10) * Get argument GETDC ZPTR,ZPTR,DESCR Get value VEQLC ZPTR,S,,DEFTV Is it STRING? VEQLC ZPTR,I,,DEFTI Is it INTEGER? RCALL A2PTR,DTREP,ZPTR Get data type representation GETSPC XSP,A2PTR,0 Get specifier GETLG SCL,XSP Get length SUM TCL,TCL,SCL Total length ACOMPC TCL,BUFLEN,FXOVR,FXOVR * Check for excessively long string DEFTIA APDSP PROTSP,XSP Append value BRANCH DEFDTT Continue with next argument *_ DEFTI INTSPC XSP,ZPTR Convert INTEGER to STRING BRANCH DEFTIA Rejoin processing *_ DEFTV LOCSP XSP,ZPTR Get specifier GETLG SCL,XSP Get length SUM TCL,TCL,SCL Get total length ACOMPC TCL,BUFLEN,FXOVR,FXOVR * Check for excessively long string APDSP PROTSP,QTSP Append quote APDSP PROTSP,XSP Append value APDSP PROTSP,QTSP Append quote DEFDTT APDSP PROTSP,CMASP Append comma BRANCH FNTRLP Continue processing *_ FENTR4 AEQLC WCL,1,,FENTR5 Leave paren if no arguments SHORTN PROTSP,1 Delete last comma FENTR5 APDSP PROTSP,RPRNSP Append right parenthesis MSTIME ZPTR Get time SUBTRT ZPTR,ZPTR,ETMCL Compute elapsed time INTSPC XSP,ZPTR Convert to STRING APDSP PROTSP,ETIMSP Append time message APDSP PROTSP,XSP Append time STPRNT IOKEY,OUTBLK,PROTSP Print trace message BRANCH RTNUL3 Return *_ FENTR2 PROC FENTR Standard entry POP WPTR Restore function name BRANCH FENTR3 *_ FXOVR OUTPUT OUTPUT,PRTOVF Print error message BRANCH RTNUL3 Return *_ *---------------------------------------------------------------------* * * Keyword and Label Tracing * KEYTR PROC , Procedure to trace keywords SETAC FNVLCL,1 Set entry indicator RCALL WPTR,VARVAL,,FAIL Get keyword LOCSP XSP,WPTR Get specifier RCALL YCL,KEYT,(WPTR),(INTR10,) * Get value of keyword KEYTR3 SETLC PROTSP,0 Clear specifier APDSP PROTSP,TRSTSP Append trace message INTSPC TSP,STNOCL Convert &STNO to string APDSP PROTSP,TSP Append &STNO APDSP PROTSP,COLSP Append colon AEQLC FNVLCL,0,,KEYTR4 Check entry indicator APDSP PROTSP,AMPSP Append ampersand KEYTR4 APDSP PROTSP,XSP Append name of keyword APDSP PROTSP,BLSP Append blank AEQLC FNVLCL,0,,KEYTR5 Check entry indicator INTSPC YSP,YCL Convert keyword value to string APDSP PROTSP,EQLSP Append equal sign KEYTR5 APDSP PROTSP,YSP Append value MSTIME YPTR Get time SUBTRT YPTR,YPTR,ETMCL Compute elapsed time INTSPC XSP,YPTR Convert time to string APDSP PROTSP,ETIMSP Append time message APDSP PROTSP,XSP Append time STPRNT IOKEY,OUTBLK,PROTSP Print trace message BRANCH RTN2 Return *_ LABTR PROC KEYTR Procedure to trace labels SETAC FNVLCL,0 Set entry indicator RCALL YPTR,VARVAL,,FAIL Get label name LOCSP YSP,YPTR Get specifier SETSP XSP,XFERSP Set up message specifier BRANCH KEYTR3 Join common processing *_ *---------------------------------------------------------------------* * * Trace Handler * TRPHND PROC , Trace handling procedure POP ATPTR Restore trace DECRA TRAPCL,1 Decrement &TRACE PUSH (LSTNCL,STNOCL,FRTNCL,OCBSCL,OCICL,TRAPCL,TRACL) * Save system descriptors GETDC OCBSCL,ATPTR,2*DESCR NEW CODE BASE * Get new code base SETAC OCICL,DESCR Set up offset GETD XPTR,OCBSCL,OCICL Get function descriptor SETAC TRAPCL,0 Set &TRACE to 0 SETAC TRACL,0 Set &FTRACE to 0 RCALL ,INVOKE,XPTR,(,) E3.3.1 * Evaluate function POP (TRACL,TRAPCL,OCICL,OCBSCL,FRTNCL,STNOCL,LSTNCL) * Restore system descriptors BRANCH RTN1 E3.3.1 *_ *---------------------------------------------------------------------* * * Value Tracing * VALTR PROC , Tracing procedures SETAC FNVLCL,1 Note entry VALTR2 RCALL XPTR,IND,,FAIL Get variable to be traced PUSH XPTR Save name RCALL ZPTR,VARVAL,,FAIL Get tag POP XPTR Restore variable VALTR4 SETLC TRACSP,0 Clear specifier APDSP TRACSP,TRSTSP Append trace message INTSPC XSP,STNOCL Convert &STNO to string APDSP TRACSP,XSP Append &STNO APDSP TRACSP,COLSP Append colon AEQLC FNVLCL,0,,FNEXT1 Check entry indicator VEQLC XPTR,S,DEFDT Is variable a string? VALTR3 LOCSP XSP,XPTR Get specifier GETLG TCL,XSP Get length ACOMPC TCL,BUFLEN,VXOVR,VXOVR * Check for excessively long name VALTR1 APDSP TRACSP,XSP Append name of variable APDSP TRACSP,BLEQSP Append ' = ' GETDC YPTR,XPTR,DESCR Get value of traced variable VEQLC YPTR,S,,TRV Is it STRING? VEQLC YPTR,I,,TRI Is it INTEGER? RCALL XPTR,DTREP,YPTR Else get data type representation GETSPC XSP,XPTR,0 Get specifier TRI2 APDSP TRACSP,XSP Append value BRANCH TRPRT Join common processing *_ TRV LOCSP XSP,YPTR Get specifier GETLG SCL,XSP Get length SUM TCL,TCL,SCL Compute total length ACOMPC TCL,BUFLEN,VXOVR,VXOVR * Check for excessively long message APDSP TRACSP,QTSP Append quote APDSP TRACSP,XSP Append string APDSP TRACSP,QTSP Append quote TRPRT MSTIME YPTR Get time SUBTRT YPTR,YPTR,ETMCL Compute time in interpreter INTSPC XSP,YPTR Convert to STRING APDSP TRACSP,ETIMSP Append time message APDSP TRACSP,XSP Append time STPRNT IOKEY,OUTBLK,TRACSP Print trace message BRANCH RTNUL3 Return *_ TRI INTSPC XSP,YPTR Convert INTEGER to STRING BRANCH TRI2 Join processing *_ DEFDT LOCSP XSP,ZPTR Get specifier for tag BRANCH VALTR1 Join processing *_ FNEXTR PROC VALTR Return tracing procedure SETAC FNVLCL,0 Note entry BRANCH VALTR2 Join processing *_ FNEXT1 APDSP TRACSP,TRLVSP Append level message MOVD XCL,LVLCL Copy &FNCLEVEL DECRA XCL,1 Decrement INTSPC XSP,XCL Convert to STRING APDSP TRACSP,XSP Append function level APDSP TRACSP,BLSP Append blank LOCSP XSP,RETPCL Get specifier for return APDSP TRACSP,XSP Append return type APDSP TRACSP,OFSP Append ' OF ' DEQL RETPCL,FRETCL,VALTR3 * Check for FRETURN LOCSP XSP,XPTR Get specifier for function name GETLG TCL,XSP Get length ACOMPC TCL,BUFLEN,VXOVR,VXOVR * Check for excessively long string APDSP TRACSP,XSP Append name of function BRANCH TRPRT Join common processing *_ FTRACE call trace FNEXT2 PROC VALTR Note entry SETAC FNVLCL,0 Restore function name POP XPTR Join common processing BRANCH VALTR4 *_ VXOVR OUTPUT OUTPUT,PRTOVF Print error message BRANCH RTNUL3 Return *_ *---------------------------------------------------------------------* TITLE 'Other Operations' * * Assignment * ASGN PROC , X = Y INCRA OCICL,DESCR Increment offset in object code GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,ASGNC Test for function descriptor ASGNV VEQLC XPTR,K,,ASGNIC Check for keyword subject INCRA OCICL,DESCR Increment offset in object code GETD YPTR,OCBSCL,OCICL Get object code descriptor TESTF YPTR,FNC,,ASGNCV Test for function descriptor ASGNVN AEQLC INSW,0,,ASGNV1 Check &INPUT LOCAPV ZPTR,INATL,YPTR,ASGNV1 * Look for input association GETDC ZPTR,ZPTR,DESCR Get input association descriptor RCALL YPTR,PUTIN,(ZPTR,YPTR),(FAIL,ASGNVV) *_ ASGNV1 GETDC YPTR,YPTR,DESCR Get value ASGNVV PUTDC XPTR,DESCR,YPTR Perform assignment AEQLC OUTSW,0,,ASGN1 Check &OUTPUT LOCAPV ZPTR,OUTATL,XPTR,ASGN1 * Look for output association GETDC ZPTR,ZPTR,DESCR Get output association descriptor RCALL ,PUTOUT,(ZPTR,YPTR) Perform output ASGN1 ACOMPC TRAPCL,0,,RTNUL3,RTNUL3 * Check &TRACE LOCAPT ATPTR,TVALL,XPTR,RTNUL3 * Look for VALUE trace RCALL ,TRPHND,ATPTR,RTNUL3 E3.3.1 *_ ASGNC RCALL XPTR,INVOKE,(XPTR),(FAIL,ASGNV,NEMO) *_ ASGNCV PUSH XPTR Save subject of assignment RCALL YPTR,INVOKE,(YPTR),(FAIL,ASGNVP) ASGNCJ POP XPTR Restore subject BRANCH ASGNVV *_ ASGNVP POP XPTR Restore subject BRANCH ASGNVN *_ ASGNIC PUSH XPTR Save subject of assignment RCALL YPTR,INTVAL,,(FAIL,ASGNCJ) * Get integer value for keyword *_ *---------------------------------------------------------------------* * * X Y (concatenation) * CON PROC , X Y (concatenation) RCALL ,XYARGS,,FAIL Get two arguments DEQL XPTR,NULVCL,,RTYPTR If first is null, return second DEQL YPTR,NULVCL,,RTXPTR If second is null, return first VEQLC XPTR,S,,CON5 Is first STRING? VEQLC XPTR,P,,CON5 Is first PATTERN? VEQLC XPTR,I,,CON4I Is first INTEGER? VEQLC XPTR,R,,CON4R Is first REAL? VEQLC XPTR,E,INTR1 Is first EXPRESSION? RCALL TPTR,BLOCK,STARSZ Allocate block for pattern MOVBLK TPTR,STRPAT,STARSZ Set up pattern for expression PUTDC TPTR,4*DESCR,XPTR Insert pointer to expression MOVD XPTR,TPTR Set up as first argument BRANCH CON5 *_ CON4R REALST REALSP,XPTR Convert REAL to STRING SETSP XSP,REALSP Set up specifier RCALL XPTR,GENVAR,XSPPTR,CON5 * Generate variable *_ CON4I INTSPC ZSP,XPTR Convert INTEGER to STRING RCALL XPTR,GENVAR,(ZSPPTR) * Generate variable CON5 VEQLC YPTR,S,,CON7 Is second STRING? VEQLC YPTR,P,,CON7 Is second PATTERN? VEQLC YPTR,I,,CON5I Is second INTEGER? VEQLC YPTR,R,,CON5R Is second REAL? VEQLC YPTR,E,INTR1 Is second EXPRESSION? RCALL TPTR,BLOCK,STARSZ Allocate block for pattern MOVBLK TPTR,STRPAT,STARSZ Set up pattern for expression PUTDC TPTR,4*DESCR,YPTR Insert pointer to expression MOVD YPTR,TPTR Set up as second argument BRANCH CON7 Join processing *_ CON5R REALST REALSP,YPTR Convert REAL to STRING SETSP YSP,REALSP Set up sepcifier RCALL YPTR,GENVAR,YSPPTR,CON7 * Generate variable *_ CON5I INTSPC ZSP,YPTR Convert INTEGER to STRING RCALL YPTR,GENVAR,(ZSPPTR) * Generate variable CON7 SETAV DTCL,XPTR Get data type of first MOVV DTCL,YPTR Get data type of second DEQL DTCL,VVDTP,,CONVV Check for STRING-STRING DEQL DTCL,VPDTP,,CONVP Check for STRING-PATTERN DEQL DTCL,PVDTP,,CONPV Check for PATTERN-STRING DEQL DTCL,PPDTP,INTR1,CONPP * Check for PATTERN-PATTERN *_ CONVV LOCSP XSP,XPTR Specifier for first string LOCSP YSP,YPTR Specifier for second string GETLG XCL,XSP Length of first string GETLG YCL,YSP Length of second string SUM XCL,XCL,YCL Total length ACOMP XCL,MLENCL,INTR8 Check against &MAXLNGTH RCALL ZPTR,CONVAR,(XCL) Allocate space for string LOCSP TSP,ZPTR Get specifier to allocated space SETLC TSP,0 Clear length APDSP TSP,XSP Move in first string APDSP TSP,YSP Append second string BRANCH GENVSZ Generate variable *_ CONVP LOCSP TSP,XPTR Specifier to string GETLG TMVAL,TSP Get length of string RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern MAKNOD XPTR,TPTR,TMVAL,ZEROCL,CHRCL,XPTR * Construct pattern CONPP GETSIZ XSIZ,XPTR Get size of first pattern GETSIZ YSIZ,YPTR Get size of second pattern SUM TSIZ,XSIZ,YSIZ Compute total size required SETVC TSIZ,P Insert PATTERN data type RCALL TPTR,BLOCK,TSIZ Allocate block for new pattern MOVD ZPTR,TPTR Save copy to return LVALUE TVAL,YPTR Get least value for second pattern CPYPAT TPTR,XPTR,TVAL,ZEROCL,XSIZ,XSIZ * Copy in first pattern CPYPAT TPTR,YPTR,ZEROCL,XSIZ,ZEROCL,YSIZ * Copy in second pattern BRANCH RTZPTR Return pattern as value *_ CONPV LOCSP TSP,YPTR Get specifier to string GETLG TMVAL,TSP Get length of string RCALL TPTR,BLOCK,LNODSZ Allocate block for pattern MAKNOD YPTR,TPTR,TMVAL,ZEROCL,CHRCL,YPTR * Construct pattern for string BRANCH CONPP Join common processing *_ *---------------------------------------------------------------------* * * Indirect Reference * IND PROC , $X RCALL XPTR,ARGVAL,,FAIL Get argument VEQLC XPTR,S,,INDV STRING is acceptable VEQLC XPTR,N,,RTXNAM NAME can be returned directly VEQLC XPTR,I,,GENVIX Convert INTEGER VEQLC XPTR,K,INTR1,RTXNAM KEYWORD is like NAME *_ INDV AEQLC XPTR,0,RTXNAM,NONAME * Be sure string is not null *_ *---------------------------------------------------------------------* * * Keywords * KEYWRD PROC , &X INCRA OCICL,DESCR Increment offset GETD XPTR,OCBSCL,OCICL Get object code descriptor TESTF XPTR,FNC,,KEYC Check for function KEYN LOCAPV XPTR,KNATL,XPTR,KEYV * Look up X on unprotected list SETVC XPTR,K Set KEYWORD (NAME) data type BRANCH RTXNAM Return by name *_ KEYV LOCAPV ATPTR,KVATL,XPTR,UNKNKW * Look up X on protected list GETDC ZPTR,ATPTR,DESCR Get value BRANCH RTZPTR Return by value *_ KEYC RCALL XPTR,INVOKE,(XPTR),(FAIL,KEYN,NEMO) * Evaluate computed keyword *_ KEYT PROC KEYWRD Procedure to get keyword for trace POP XPTR Restore argument BRANCH KEYN *_ Join common processing *---------------------------------------------------------------------* * Literal Evaluation * * LIT PROC , 'X' INCRA OCICL,DESCR Increment offset GETD ZPTR,OCBSCL,OCICL Get object code descriptor BRANCH RTZPTR Return value *_ *---------------------------------------------------------------------* * * Unary Name Operator * NAME PROC , .X INCRA OCICL,DESCR Increment offset GETD ZPTR,OCBSCL,OCICL Get object code descriptor TESTF ZPTR,FNC,RTZPTR Test for function RCALL ZPTR,INVOKE,ZPTR,(FAIL,RTZPTR,NEMO) *_ * * *---------------------------------------------------------------------* * * Value Assignment in Pattern Matching * NMD PROC , MOVD TCL,NHEDCL NMD1 ACOMP TCL,NAMICL,INTR13,RTN2 * Check for end SUM TPTR,NBSPTR,TCL Compute address GETSPC TSP,TPTR,DESCR Get specifier GETDC TVAL,TPTR,DESCR+SPEC * get variable GETLG XCL,TSP Get length ACOMP XCL,MLENCL,INTR8 Check &MAXLNGTH VEQLC TVAL,E,,NAMEXN Is Variable EXPRESSION? NMD5 VEQLC TVAL,K,,NMDIC Is variable KEYWORD? RCALL VVAL,GENVAR,(TSPPTR) * Generate string NMD4 PUTDC TVAL,DESCR,VVAL Assign value AEQLC OUTSW,0,,NMD3 Check &OUTPUT LOCAPV ZPTR,OUTATL,TVAL,NMD3 * Look for output association GETDC ZPTR,ZPTR,DESCR Get association RCALL ,PUTOUT,(ZPTR,VVAL) Perform output NMD3 ACOMPC TRAPCL,0,,NMD2,NMD2 Check &TRACE LOCAPT ATPTR,TVALL,TVAL,NMD2 * Look for VALUE trace PUSH (TCL,NAMICL,NHEDCL) Save state MOVD NHEDCL,NAMICL Set up new name list RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace POP (NHEDCL,NAMICL,TCL) Restore state NMD2 INCRA TCL,DESCR+SPEC Move to next name BRANCH NMD1 Continue *_ NMDIC SPCINT VVAL,TSP,INTR1,NMD4 Convert to INTEGER *_ NAMEXN RCALL TVAL,EXPEVL,TVAL,(FAIL,NMD5,NEMO) E3.10.5 * Evaluate expression *_ *---------------------------------------------------------------------* * * Unevaluated Expression * STR PROC , *X SUM ZPTR,OCBSCL,OCICL Compute position in code RCALL ,CODSKP,(ONECL) Skip one nest SETVC ZPTR,E Insert EXPRESSION data type BRANCH RTZPTR Return pointer to code *_ *---------------------------------------------------------------------* TITLE 'Other Predicates' * * DIFFER(X,Y) * DIFFER PROC , DIFFER(X,Y) RCALL ,XYARGS,,FAIL Evaluate arguments DEQL XPTR,YPTR,RETNUL,FAIL * Compare them *_ *---------------------------------------------------------------------* * * IDENT(X,Y) * IDENT PROC , IDENT(X,Y) RCALL ,XYARGS,,FAIL Evaluate arguments DEQL XPTR,YPTR,FAIL,RETNUL * Compare arguments *_ *---------------------------------------------------------------------* * * LGT(X,Y) * LGT PROC , LGT(X,Y) RCALL XPTR,VARVAL,,FAIL Evaluate first argument PUSH XPTR Save first argument RCALL YPTR,VARVAL,,FAIL Evaluate second argument POP XPTR Restore first argument AEQLC XPTR,0,,FAIL Null is not greater than anything AEQLC YPTR,0,,RETNUL Similarly for second argument LOCSP XSP,XPTR Get specifier to first argument LOCSP YSP,YPTR Get specifier to second argument LEXCMP XSP,YSP,RETNUL,FAIL,FAIL * Compare lexically *_ *---------------------------------------------------------------------* * * Unary Negation Operator * NEG PROC , \X PUSH (OCBSCL,OCICL) Save object code position RCALL ,ARGVAL,,(,FAIL) Fail on success POP (OCICL,OCBSCL) Restore object code position RCALL ,CODSKP,(ONECL),RETNUL * Skip argument and return *_ *---------------------------------------------------------------------* * * Unary Interrogation Operator * QUES PROC , ?X RCALL ,ARGVAL,,(FAIL,RETNUL) * Evaluate argument *_ *---------------------------------------------------------------------* TITLE 'Other Functions' * * APPLY(F,A1,...AN) * APPLY PROC , APPLY(F,A1,...,AN) SETAV XCL,INCL Get count of arguments DECRA XCL,1 Decrement to skip function name ACOMPC XCL,1,,,ARGNER E3.3.3 PUSH XCL Save argument count RCALL XPTR,VARVAL,,FAIL Get function name POP XCL Restore argument count LOCAPV XPTR,FNCPL,XPTR,UNDF * Locate function GETDC INCL,XPTR,DESCR Get function descriptor SETVA INCL,XCL Insert actual number of arguments RCALL ZPTR,INVOKE,(INCL),(FAIL,,RTZPTR) MOVD XPTR,ZPTR Return by name BRANCH RTXNAM *_ *---------------------------------------------------------------------* * * ARG(F,N), FIELD(F,N), and LOCAL(F,N) * ARG PROC , ARG(F,N) PUSH (ONECL,DEFCL) Save ARG indicators BRANCH ARG1 Join main processing *_ ARGINT PROC ARG Procedure used for CALL tracing POP (XPTR,XCL) Restore arguments PUSH (ONECL,DEFCL) Save indicators BRANCH ARG2 Join processing *_ LOCAL PROC ARG LOCAL(F,N) PUSH (ONECL,ZEROCL,DEFCL) * Save LOCAL indicators BRANCH ARG1 Join main processing *_ FIELDS PROC ARG FIELD(F,N) PUSH (ZEROCL,ZEROCL,DATCL) * Save FIELD indicators ARG1 RCALL XPTR,VARVAL,,FAIL Get function name PUSH XPTR Save function name RCALL XCL,INTVAL,,FAIL Get number ACOMP ZEROCL,XCL,FAIL,FAIL * Verify positive number POP XPTR Restore function name ARG2 LOCAPV XPTR,FNCPL,XPTR,INTR30 * Look for function descriptor GETDC XPTR,XPTR,DESCR Get function descriptor GETDC YCL,XPTR,0 Get procedure descriptor GETDC XPTR,XPTR,DESCR Get definition block POP (ZCL,ALCL) Restore indicators AEQL YCL,ZCL,INTR30 Check procedure type MULTC XCL,XCL,DESCR Convert number to address units INCRA XCL,2*DESCR Skip prototype information SETAV YCL,YCL Get argument count MULTC YCL,YCL,DESCR Convert to address units AEQLC ALCL,0,,ARG4 Check funcion type INCRA YCL,2*DESCR Increment for heading MOVD ZCL,YCL Get working copy BRANCH ARG5 Branch to continue processing *_ ARG4 GETSIZ ZCL,XPTR Get size of block POP ALCL Restore entry indicator AEQLC ALCL,0,,ARG5 Check entry type SUM XCL,XCL,YCL Skip formal arguments ARG5 ACOMP XCL,ZCL,FAIL Check number in bounds GETD ZPTR,XPTR,XCL Get the desired name BRANCH RTZPTR Return name as value *_ *---------------------------------------------------------------------* * * CLEAR() * CLEAR PROC , CLEAR() RCALL ,ARGVAL,,FAIL Get rid of argument SETAC DMPPTR,OBLIST-DESCR Initialize bin pointer CLEAR1 ACOMP DMPPTR,OBEND,RETNUL Check for end INCRA DMPPTR,DESCR Update for next bin MOVD YPTR,DMPPTR Get working copy CLEAR2 GETAC YPTR,YPTR,LNKFLD Get next variable AEQLC YPTR,0,,CLEAR1 Check for end of chain PUTDC YPTR,DESCR,NULVCL Assign null value BRANCH CLEAR2 Continue *_ *---------------------------------------------------------------------* * * COLLECT(N) * COLECT PROC , COLLECT(N) RCALL XPTR,INTVAL,,FAIL Get number of address units required ACOMPC XPTR,0,,,LENERR Verify positive integer RCALL ZPTR,GC,(XPTR),FAIL Call for storage regeneration SETVC ZPTR,I Set INTEGER data type BRANCH RTZPTR Return amount collected *_ *---------------------------------------------------------------------* * * COPY(X) * COPY PROC , COPY(X) RCALL XPTR,ARGVAL,,FAIL Get object to copy VEQLC XPTR,S,,INTR1 STRING cannot be copied VEQLC XPTR,I,,INTR1 INTEGER cannot be copied VEQLC XPTR,R,,INTR1 REAL cannot be copied VEQLC XPTR,N,,INTR1 NAME cannot be copied VEQLC XPTR,K,,INTR1 KEYWORD (NAME) cannot be copied VEQLC XPTR,E,,INTR1 EXPRESSION cannot be copied VEQLC XPTR,T,,INTR1 TABLE cannot be copied GETSIZ XCL,XPTR Get size of object to copy MOVV XCL,XPTR Insert data type RCALL ZPTR,BLOCK,XCL Allocate block for copy MOVBLK ZPTR,XPTR,XCL Copy contents BRANCH RTZPTR Return the copy *_ *---------------------------------------------------------------------* * * CONVERT(X,T) * CNVRT PROC , CONVERT(X,T) RCALL ZPTR,ARGVAL,,FAIL Get object to be converted PUSH ZPTR Save object RCALL YPTR,VARVAL,,FAIL Get data type target POP ZPTR Restore object LOCAPV XPTR,DTATL,YPTR,INTR1 * Look for data type code GETDC XPTR,XPTR,DESCR Get code SETAV DTCL,ZPTR Insert object data type MOVV DTCL,XPTR Insert target data type DEQL DTCL,IVDTP,,CNVIV Check for INTEGER-STRING DEQL DTCL,VCDTP,,RECOMP Check for STRING-CODE DEQL DTCL,VEDTP,,CONVE DEQL DTCL,VRDTP,,CONVR Check for STRING-REAL DEQL DTCL,RIDTP,,CONRI Check for REAL-INTEGER DEQL DTCL,IRDTP,,CONIR Check for INTEGER-REAL DEQL DTCL,VIDTP,,CNVVI CHeck for STRING-INTEGER DEQL DTCL,ATDTP,,CNVAT Check for ARRAY-TABLE DEQL DTCL,TADTP,,CNVTA Check for TABLE-ARRAY VEQL ZPTR,XPTR,,RTZPTR E3.0.4 VEQLC XPTR,S,FAIL,CNVRTS E3.0.4 * Check for idem-conversion *_ RECOMP SETAC SCL,1 Note STRING-CODE conversion RECOMJ LOCSP TEXTSP,ZPTR Set up global specifier RECOMT GETLG OCALIM,TEXTSP E3.1.5 AEQLC OCALIM,0,,RECOMN E3.1.5 MULTC OCALIM,OCALIM,DESCR Convert to address units INCRA OCALIM,6*DESCR Leave room for safety SETVC OCALIM,C Insert CODE data type RCALL CMBSCL,BLOCK,OCALIM Allocate block for object code SUM OCLIM,CMBSCL,OCALIM Compute end DECRA OCLIM,6*DESCR SETAC CMOFCL,0 Zero offset SETAC ESAICL,0 Zero error count PUSH CMBSCL Save block pointer SELBRA SCL,(,CONVEX) Select correct procedure RECOM1 LEQLC TEXTSP,0,,RECOM2 Is string exhausted? RCALL ,CMPILE,,(RECOMF,,RECOM1) * Compile statement RECOM2 SETAC SCL,3 Set return switch RECOMQ INCRA CMOFCL,DESCR Increment offset PUTD CMBSCL,CMOFCL,ENDCL Insert END function POP ZPTR Restore pointer to code block RECOMZ SUM CMBSCL,CMBSCL,CMOFCL * Compute used portion of block RCALL ,SPLIT,(CMBSCL) Split off remainder SETAC OCLIM,0 Clear limit pointer SETAC LPTR,0 Clear label pointer ZERBLK COMREG,COMDCT Zero compiler descriptors SELBRA SCL,(FAIL,INTR10,RTZPTR) * Select return *_ RECOMF SETAC SCL,1 Set failure return BRANCH RECOMQ Rejoin processing *_ RECOMN SETSP TEXTSP,BLSP E3.1.5 BRANCH RECOMT E3.1.5 *_ E3.1.5 CODER PROC CNVRT CODE(S) RCALL ZPTR,VARVAL,,(FAIL,RECOMP) * Get argument *_ CONVE PROC CNVRT Convert to EXPRESSION SETAC SCL,2 Set switch BRANCH RECOMJ Join common program *_ CONVEX RCALL FORMND,EXPR,,FAIL Compile expression LEQLC TEXTSP,0,FAIL Verify complete compilation RCALL ,TREPUB,FORMND Publish code tree MOVD ZPTR,CMBSCL E3.1.6 SETVC ZPTR,E Insert EXPRESSION data type SETAC SCL,3 Set return branch BRANCH RECOMZ Join common program *_ CONVR LOCSP ZSP,ZPTR Get specifier SPCINT ZPTR,ZSP,,CONIR Try conversion to INTEGER first SPREAL ZPTR,ZSP,FAIL,RTZPTR * Convert to REAL *_ CONIR INTRL ZPTR,ZPTR Convert INTEGER to REAL BRANCH RTZPTR Return value *_ CONRI RLINT ZPTR,ZPTR,FAIL,RTZPTR * Convert REAL to INTEGER *_ CNVIV RCALL ZPTR,GNVARI,ZPTR,RTZPTR * Convert INTEGER to STRING *_ CNVVI LOCSP ZSP,ZPTR Get specifier SPCINT ZPTR,ZSP,,RTZPTR Convert STRING to INTEGER SPREAL ZPTR,ZSP,FAIL,CONRI Try conversion to REAL *_ CNVRTS RCALL XPTR,DTREP,ZPTR Get data type representation GETSPC ZSP,XPTR,0 Get specifier BRANCH GENVRZ Go generate variable *_ CNVTA MOVD YPTR,ZPTR E3.2.3 MOVD YCL,ZEROCL E3.2.3 CNVTA7 GETSIZ XCL,YPTR E3.2.3 MOVD WPTR,YPTR E3.2.3 MOVD ZCL,XCL E3.2.3 DECRA XCL,3*DESCR E3.2.3 CNVTA1 GETD WCL,WPTR,XCL Get item value DEQL WCL,NULVCL,,CNVTA2 Check for null value INCRA YCL,1 Otherwise count item CNVTA2 AEQLC XCL,DESCR,,CNVTA6 E3.2.3 DECRA XCL,2*DESCR Count down BRANCH CNVTA1 Process next item *_ CNVTA6 GETD YPTR,YPTR,ZCL E3.2.3 AEQLC YPTR,1,CNVTA7 E3.2.3 CNVTA4 AEQLC YCL,0,,FAIL Fail on empty table MOVD WPTR,ZPTR E3.2.3 MULTC XCL,YCL,2*DESCR Convert count to address units INTSPC YSP,YCL Get prototype for size SETLC PROTSP,0 Clear specifier APDSP PROTSP,YSP Append length APDSP PROTSP,CMASP Append comma MOVD WCL,ZEROCL E3.1.1 SETAC WCL,2 Set up 2 for second dimension INTSPC XSP,WCL Convert to string APDSP PROTSP,XSP Append 2 SETSP XSP,PROTSP Move specifier RCALL TPTR,GENVAR,XSPPTR E3.5.2 * Generate variable for prototype MOVD ZCL,XCL Save size INCRA XCL,4*DESCR Increment for heading RCALL ZPTR,BLOCK,XCL Get block for array SETVC ZPTR,A Insert ARRAY data type MOVD ATPRCL,TPTR E3.5.2 SETVA ATEXCL,YCL Insert First dimension in head MOVBLK ZPTR,ATRHD,FRDSCL Copy heading information MOVD YPTR,ZPTR Save copy of block pointer MULTC YCL,YCL,DESCR Convert item count to address units INCRA YPTR,5*DESCR Skip heading SUM TPTR,YPTR,YCL Compute second half position CNVTA8 GETSIZ WCL,WPTR E3.2.3 DECRA WCL,2*DESCR E3.2.3 SUM WCL,WPTR,WCL E3.2.3 CNVTA3 GETDC TCL,WPTR,DESCR E3.2.3 DEQL TCL,NULVCL,,CNVTA5 E3.2.3 PUTDC TPTR,0,TCL E3.2.3 MOVDIC YPTR,0,WPTR,2*DESCR INCRA YPTR,DESCR Increment upper pointer INCRA TPTR,DESCR Increment lower pointer CNVTA5 INCRA WPTR,2*DESCR AEQL WCL,WPTR,CNVTA3 E3.2.3 GETDC WPTR,WCL,2*DESCR E3.2.3 AEQLC WPTR,1,CNVTA8 E3.8.1 SETAC TPTR,0 E3.8.1 BRANCH RTZPTR E3.8.1 *_ CNVAT GETDC XCL,ZPTR,2*DESCR Get array dimensionality MOVD YPTR,ZPTR Save copy of array pointer AEQLC XCL,2,FAIL Verify rectangular array GETDC XCL,ZPTR,3*DESCR Get second dimension VEQLC XCL,2,FAIL Verify extent of 2 GETSIZ XCL,ZPTR Get size of array block DECRA XCL,2*DESCR E3.2.3 RCALL XPTR,BLOCK,XCL Allocate block for pair list SETVC XPTR,T E3.2.3 GETDC YCL,ZPTR,4*DESCR E3.2.3 MOVD ZPTR,XPTR E3.2.3 PUTD XPTR,XCL,ONECL E3.2.3 DECRA XCL,DESCR E3.2.3 MOVD TCL,EXTVAL E3.2.3 INCRA TCL,2*DESCR E3.2.3 PUTD XPTR,XCL,TCL E3.2.3 SETAV YCL,YCL E3.2.3 MULTC YCL,YCL,DESCR E3.2.3 INCRA YPTR,5*DESCR E3.2.3 SUM WPTR,YPTR,YCL E3.2.3 CNVAT2 MOVDIC XPTR,DESCR,WPTR,0 E3.2.3 MOVDIC XPTR,2*DESCR,YPTR,0 E3.2.3 DECRA YCL,DESCR E3.2.3 AEQLC YCL,0,,RTZPTR E3.2.3 INCRA XPTR,2*DESCR Increment pair list pointer INCRA WPTR,DESCR Increment lower array pointer INCRA YPTR,DESCR Increment upper array pointer BRANCH CNVAT2 Continue *_ *---------------------------------------------------------------------* * * DATE() * DATE PROC , DATE() RCALL ,ARGVAL,,FAIL Get rid of argument DATE ZSP Get the date BRANCH GENVRZ Go generate the variable *_ *---------------------------------------------------------------------* * * DATATYPE(X) * DT PROC , DATATYPE(X) RCALL A2PTR,ARGVAL,,FAIL Get object MOVV DT1CL,A2PTR Insert data type LOCAPT A3PTR,DTATL,DT1CL,DTEXTN * Look for data type GETDC A3PTR,A3PTR,2*DESCR Get data type name DTRTN RRTURN A3PTR,3 Return name *_ DTEXTN MOVD A3PTR,EXTPTR Set up EXTERNAL data type BRANCH DTRTN Return *_ *---------------------------------------------------------------------* * * DUMP(N) * DMP PROC , DUMP(N) RCALL XPTR,INTVAL,,FAIL Evaluate argument AEQLC XPTR,0,,RETNUL No dump if zero DUMP PROC DMP End game dump procedure SETAC WPTR,OBLIST-DESCR Initialize bin list pointer DMPB ACOMP WPTR,OBEND,RETNUL Check for end INCRA WPTR,DESCR Increment pointer MOVD YPTR,WPTR Save working copy DMPA GETAC YPTR,YPTR,LNKFLD Get string structure AEQLC YPTR,0,,DMPB Check for end of chain GETDC XPTR,YPTR,DESCR Get value DEQL XPTR,NULVCL,,DMPA Skip null string values SETLC DMPSP,0 Clear specifier LOCSP YSP,YPTR Get specifier for variable GETLG YCL,YSP Get length ACOMPC YCL,BUFLEN,DMPOVR,DMPOVR * Check for excessive length APDSP DMPSP,YSP Append variable APDSP DMPSP,BLEQSP Append ' = ' VEQLC XPTR,S,,DMPV STRING is alright VEQLC XPTR,I,,DMPI Convert INTEGER RCALL A1PTR,DTREP,XPTR Else get representation GETSPC YSP,A1PTR,0 Get specifier DMPX GETLG XCL,YSP Get length SUM YCL,YCL,XCL Get total ACOMPC YCL,BUFLEN,DMPOVR Check for excessive length APDSP DMPSP,YSP Append value BRANCH DMPRT Go print it *_ DMPV LOCSP YSP,XPTR Get specifier GETLG XCL,YSP Get length SUM YCL,YCL,XCL Total length ACOMPC YCL,BUFLEN,DMPOVR Check for excessive length APDSP DMPSP,QTSP Append quote APDSP DMPSP,YSP Append value APDSP DMPSP,QTSP Append quote DMPRT STPRNT IOKEY,OUTBLK,DMPSP Print line BRANCH DMPA Continue *_ DMPI INTSPC YSP,XPTR Convert integer BRANCH DMPX Rejoin processing *_ DMPOVR OUTPUT OUTPUT,PRTOVF Print error message BRANCH DMPA Continue *_ DMK PROC , Procedure to dump keywords OUTPUT OUTPUT,PKEYF Print caption GETSIZ XCL,KNLIST Get size of pair list DMPK1 GETD XPTR,KNLIST,XCL Get name of keyword DECRA XCL,DESCR Adjust offset GETD YPTR,KNLIST,XCL Get value of keyword INTSPC YSP,YPTR Convert integer to string LOCSP XSP,XPTR Get specifier SETLC DMPSP,0 Clear specifier APDSP DMPSP,AMPSP Append ampersand APDSP DMPSP,XSP Append name APDSP DMPSP,BLEQSP Append ' = ' APDSP DMPSP,YSP Append value STPRNT IOKEY,OUTBLK,DMPSP Print line DECRA XCL,DESCR Adjust offset AEQLC XCL,0,DMPK1,RTN1 Check for end *_ *---------------------------------------------------------------------* * * DUPL(S,N) * DUPL PROC , DUPL(S,N) RCALL XPTR,VARVAL,,FAIL Get string to duplicate PUSH XPTR Save string RCALL YPTR,INTVAL,,FAIL Get duplication factor POP XPTR Restore string ACOMPC YPTR,0,,RETNUL,FAIL Return null for 0 duplications LOCSP XSP,XPTR Get specifier GETLG XCL,XSP Get length MULT XCL,XCL,YPTR,AERROR E3.9.3 ACOMP XCL,MLENCL,INTR8 Check &MAXLNGTH RCALL ZPTR,CONVAR,XCL Allocate space for string LOCSP TSP,ZPTR Get specifier SETLC TSP,0 Zero length DUPL1 APDSP TSP,XSP Append a copy DECRA YPTR,1 Count down AEQLC YPTR,0,DUPL1,GENVSZ Check for end *_ *---------------------------------------------------------------------* * * OPSYN(F1,F2,N) * OPSYN PROC , OPSYN(F,G,N) RCALL XPTR,VARVAL,,FAIL Get object function PUSH XPTR Save object function RCALL YPTR,VARVAL,,FAIL Get image function PUSH YPTR Save image function RCALL ZPTR,INTVAL,,FAIL Get type indicator POP (YPTR,XPTR) Restore image and object functions AEQLC XPTR,0,,NONAME Object may not be null AEQLC ZPTR,1,,UNYOP Check for unary definition AEQLC ZPTR,2,,BNYOP Check for binary definition AEQLC ZPTR,0,INTR30 Check for function definition RCALL XPTR,FINDEX,XPTR Get function descriptor for object UNBF RCALL YPTR,FINDEX,YPTR E3.6.2 OPPD MOVDIC XPTR,0,YPTR,0 Move procedure descriptor pair MOVDIC XPTR,DESCR,YPTR,DESCR BRANCH RETNUL *_ UNYOP LOCSP XSP,XPTR Get specifier for image LEQLC XSP,1,UNAF Length must be 1 for operator SETSP ZSP,PROTSP E3.5.3 SETLC ZSP,0 E3.5.3 APDSP ZSP,XSP E3.5.3 APDSP ZSP,LPRNSP E3.5.3 STREAM TSP,ZSP,UNOPTB,UNAF,UNAF E3.5.3 MOVD XPTR,STYPE STYPE has function descriptor UNCF LOCSP YSP,YPTR Get specifier for image LEQLC YSP,1,UNBF Length must be 1 for operator SETSP ZSP,PROTSP E3.5.3 SETLC ZSP,0 E3.5.3 APDSP ZSP,YSP E3.5.3 APDSP ZSP,LPRNSP E3.5.3 STREAM TSP,ZSP,UNOPTB,UNBF,UNBF E3.5.3 MOVD YPTR,STYPE STYPE has function descriptor BRANCH OPPD Join to copy descriptors *_ UNAF RCALL XPTR,FINDEX,XPTR Find definition of image BRANCH UNCF Join search for object *_ BNYOP LOCSP XSP,XPTR Get specifier for image LCOMP XSP,EQLSP,BNAF Length must be 2 or less SETSP ZSP,PROTSP E3.5.3 SETLC ZSP,0 E3.5.3 APDSP ZSP,XSP E3.5.3 APDSP ZSP,BLSP E3.5.3 STREAM TSP,ZSP,BIOPTB,BNAF,BNAF E3.5.3 LEQLC ZSP,0,BNAF E3.5.3 MOVD XPTR,STYPE STYPE has function descriptor BNCF LOCSP YSP,YPTR Get specifier for object LCOMP YSP,EQLSP,BNBF Length must be 2 or less SETSP ZSP,PROTSP E3.5.3 SETLC ZSP,0 E3.5.3 APDSP ZSP,YSP E3.5.3 APDSP ZSP,BLSP E3.5.3 STREAM TSP,ZSP,BIOPTB,BNBF,BNBF E3.5.3 LEQLC ZSP,0,BNBF E3.5.3 MOVD YPTR,STYPE STYPE has function descriptor BRANCH OPPD Join to copy descriptors *_ BNAF LEXCMP XSP,BLSP,,BNCN Check for concatenation RCALL XPTR,FINDEX,XPTR Find definition of image BRANCH BNCF Join search for object *_ BNCN MOVD XPTR,CONCL CONCL represents concatenation BRANCH BNCF Join search for object *_ BNBF LEXCMP YSP,BLSP,UNBF,,UNBF Check for concatenation MOVD YPTR,CONCL CONCL represents concatenation BRANCH OPPD Join to copy descriptors *_ *---------------------------------------------------------------------* * * REPLACE(S1,S2,S3) * RPLACE PROC , REPLACE(S1,S2,S3) RCALL XPTR,VARVAL,,FAIL Get first argument PUSH XPTR Save first argument RCALL YPTR,VARVAL,,FAIL Get second argument PUSH YPTR Save second argument RCALL ZPTR,VARVAL,,FAIL Get third argument POP (YPTR,XPTR) Restore first and second AEQLC XPTR,0,,RTXPTR Ignore replacement on null LOCSP YSP,YPTR Get specifier for second LOCSP ZSP,ZPTR Get specifier for third LCOMP ZSP,YSP,FAIL,,FAIL Verify same lengths AEQLC YPTR,0,,FAIL Ignore null replacement LOCSP XSP,XPTR Get specifier for first GETLG XCL,XSP Get length RCALL ZPTR,CONVAR,XCL Allocate space for result LOCSP TSP,ZPTR Get specifier SETLC TSP,0 Clear specifier APDSP TSP,XSP Append first argument RPLACE TSP,YSP,ZSP Perform replacement BRANCH GENVSZ Got generate variable *_ *---------------------------------------------------------------------* * * SIZE(S) * SIZE PROC , SIZE(S) RCALL XPTR,VARVAL,,FAIL Get argument LOCSP XSP,XPTR Get specifier GETLG ZPTR,XSP Get length SETVC ZPTR,I Insert INTEGER data type BRANCH RTZPTR Return length *_ *---------------------------------------------------------------------* * * TIME() * TIME PROC , TIME() RCALL ,ARGVAL,,FAIL Get rid of argument MSTIME ZPTR Get elapsAL time SUBTRT ZPTR,ZPTR,ETMCL Compute time in interpreter SETVC ZPTR,I Insert INTEGER data type BRANCH RTZPTR Return time *_ *---------------------------------------------------------------------* * * TRIM(S) * TRIM PROC , TRIM(S) RCALL XPTR,VARVAL,,FAIL Get string LOCSP ZSP,XPTR Get specifier TRIMSP ZSP,ZSP Trim string BRANCH GENVRZ Generate new variable *_ *---------------------------------------------------------------------* TITLE 'Common Code' DATA LHERE , RT1NUL RRTURN NULVCL,1 Return null string by exit 1 *_ RTN1 LHERE , FAIL RRTURN ,1 Return by exit 1 *_ RETNUL RRTURN NULVCL,3 Return null string by exit 3 *_ RTN2 RRTURN ,2 Return by exit 2 *_ RTN3 LHERE , RTNUL3 RRTURN ,3 Return by exit 3 *_ RTXNAM RRTURN XPTR,2 Return XPTR by exit 2 *_ RTXPTR RRTURN XPTR,3 Return XPTR by exit 3 *_ RTYPTR RRTURN YPTR,3 Return YPTR by exit 3 *_ ARTN INCRA ARTHCL,1 Increment count of arithmetic RTZPTR RRTURN ZPTR,3 Return ZPTR by exit 3 *_ A5RTN RRTURN A5PTR,1 Return A5PTR by exit 1 *_ TSALF BRANCH SALF,SCNR Branch to SALF in scanner *_ TSALT BRANCH SALT,SCNR Branch to SALT in scanner *_ TSCOK BRANCH SCOK,SCNR Branch to SCOK in scanner *_ GENVSZ RCALL ZPTR,GNVARS,XCL,RTZPTR * Generate variable from storage *_ GENVRZ RCALL ZPTR,GENVAR,ZSPPTR,RTZPTR * Generate variable *_ GENVIX RCALL XPTR,GNVARI,XPTR,RTXNAM * Generate variable from integer *_ TITLE 'Termination' END OUTPUT OUTPUT,NRMEND,(LVLCL) * End procedure OUTPUT OUTPUT,LASTSF,(STNOCL) * Print status BRANCH FTLEN2 Join termination procedure *_ FTLEND OUTPUT OUTPUT,FTLCF,(ERRTYP,STNOCL,LVLCL) V3.7 AEQLC INICOM,0,FTLEN3 BE SURE OF INITIALIZATION E3.10.6 OUTPUT OUTPUT,ALOCFL WARN USER E3.10.6 BRANCH ENDALL GET OUT E3.10.6 *_ E3.10.6 FTLEN3 MULTC YCL,ERRTYP,DESCR E3.10.6 GETD YCL,MSGNO,YCL Get message pointer GETSPC TSP,YCL,0 Get message specifier STPRNT IOKEY,OUTBLK,TSP Print error message FTLEN2 ISTACK , Reset system stack AEQLC ETMCL,0,FTLEN4 Was compiler done? MSTIME ETMCL Time out compiler SUBTRT TIMECL,ETMCL,TIMECL Compute time in compiler SETAC ETMCL,0 Set interpreter time to 0 BRANCH FTLEN1 Join end game *_ FTLEN4 MSTIME XCL Time out interpreter SUBTRT ETMCL,XCL,ETMCL Compute time in interpreter FTLEN1 AEQLC DMPCL,0,,END1 Check &DUMP AEQLC NODPCL,0,DMPNO Check storage condition ORDVST , Order string structures OUTPUT OUTPUT,STDMP Print dump title OUTPUT OUTPUT,NVARF Print subtitle RCALL ,DUMP,,(INTR10,INTR10,DMPK) * Dump natural variables *_ DMPNO OUTPUT OUTPUT,INCGCF Print disclaimer OUTPUT OUTPUT,NODMPF Print reason BRANCH END1 Join end game *_ DMPK RCALL ,DMK Dump keywords END1 OUTPUT OUTPUT,STATHD Print statistics title OUTPUT OUTPUT,CMTIME,(TIMECL) * Print compilation time OUTPUT OUTPUT,INTIME,(ETMCL) * Print interpretation time OUTPUT OUTPUT,EXNO,(EXNOCL,FALCL) * Print execution stats OUTPUT OUTPUT,ARTHNO,(ARTHCL) * Print arithmetic stats OUTPUT OUTPUT,SCANNO,(SCNCL) * Print scanner stats OUTPUT OUTPUT,STGENO,(GCNO) * Print regeneration stats OUTPUT OUTPUT,READNO,(RSTAT) * Print read stats OUTPUT OUTPUT,WRITNO,(WSTAT) * Print write stats AEQLC EXNOCL,0,END2 Check for no interpretation INTRL FCL,ZEROCL BRANCH AVTIME Join end game *_ END2 INTL EXNOCL,EXNOCL Convert execution total tn RAL INTRL XCL,ETMCL Convert execution time to REAL DVREAL FCL,XCL,EXNOCL Compute average time AVTIME OUTPUT OUTPUT,TIMEPS,(FCL) Print average time ENDALL ENDEX ABNDCL E3.2.2 *_ SYSCUT OUTPUT OUTPUT,SYSCMT,(STNOCL,LVLCL) * System cut exit AEQLC CUTNO,0,ENDALL E3.2.2 SETAC CUTNO,1 E3.2.2 BRANCH FTLEN2 Join end game *_ *---------------------------------------------------)-----------------* TITLE 'Error Handling' "% AERROR SETAC ERRTYP,2 Arithmetic error BRANCH FTLTST *_ ALOC2 SETAC ERRTYP,20 Storage exhausted BRANCH FTLEND *_ ARGNER SETAC ERRTYP,25 Incorrect number of arguments BRANCH FTLEND *_ INTR10 LHERE , INTR13 LHERE , COMP3 SETAC ERRTYP,17 Program error BRANCH FTLEND *_ COMP5 SETAC ERRTYP,11 Reading error BRANCH FTLTST *_ COMP7 SETAC ERRTYP,27 Erroneous end statement BRANCH FTLEND *_ COMP9 SETAC ERRTYP,26 Compilation error limit DECRA ESAICL,DESCR Decrement error count BRANCH FTLEND *_ EROR SETAC ERRTYP,28 Erroneous statement INCRA OCICL,DESCR Increment offset GETD STNOCL,OCBSCL,OCICL Get statement number BRANCH FTLEND *_ EXEX SETAC ERRTYP,22 Exceeded &STLIMIT BRANCH FTLEND *_ INTR1 SETAC ERRTYP,1 Illegal data type BRANCH FTLTST *_ INTR4 SETAC ERRTYP,24 Erroneous goto BRANCH FTLEND *_ INTR5 SETAC ERRTYP,19 Failure in goto BRANCH FTLEND *_ INTR8 SETAC ERRTYP,15 Exceeded &MAXLNGTH BRANCH FTLTST *_ INTR27 SETAC ERRTYP,13 Excessive data types BRANCH FTLTST *_ INTR30 SETAC ERRTYP,10 Illegal argument BRANCH FTLTST *_ INTR31 SETAC ERRTYP,16 Overflow in pattern matching SETAC SCERCL,3 BRANCH FTERST *_ LENERR SETAC ERRTYP,14 Negative number BRANCH FTLTST *_ MAIN1 SETAC ERRTYP,18 Return from level zero BRANCH FTLEND *_ NEMO SETAC ERRTYP,8 Variable not present BRANCH FTLTST *_ NONAME SETAC ERRTYP,4 Null string BRANCH FTLTST *_ NONARY SETAC ERRTYP,3 Erroneous array or table reference BRANCH FTLTST *_ OVER SETAC ERRTYP,21 Stack overflow BRANCH FTLEND *_ PROTER SETAC ERRTYP,6 Erroneous prototype BRANCH FTLTST *_ SCDTER SETAC ERRTYP,1 Illegal data type BRANCH SCERST *_ SCLENR SETAC ERRTYP,14 Negative number BRANCH SCERST *_ SCLNOR SETAC ERRTYP,15 String overflow BRANCH SCERST *_ SCNAME SETAC ERRTYP,4 Null string BRANCH SCERST *_ SCNEMO SETAC ERRTYP,8 E3.4.4 BRANCH SCERST E3.4.4 *_ E3.4.4 SIZERR SETAC ERRTYP,23 Object too large BRANCH FTLEND *_ UNDF SETAC ERRTYP,5 Undefined function BRANCH FTLTST *_ UNDFFE SETAC ERRTYP,9 Function entry point not label BRANCH FTLTST *_ UNKNKW SETAC ERRTYP,7 Unknown keyword BRANCH FTLTST *_ UNTERR SETAC ERRTYP,12 Illegal I/O unit BRANCH FTLTST *_ SCERST SETAC SCERCL,1 Note failure during pattern matching BRANCH FTERST *_ FTLTST SETAC SCERCL,2 Note failure out of pattern matching FTERST ACOMPC ERRLCL,0,,FTLEND,FTLEND * Check &ERRLIMIT DECRA ERRLCL,1 Decrement &ERRLIMIT ACOMPC TRAPCL,0,,FTERBR,FTERBR * Check &TRACE LOCAPT ATPTR,TKEYL,ERRTKY,FTERBR * Look for KEYWORD trace PUSH SCERCL E3.1.3 RCALL ,TRPHND,ATPTR E3.3.1 * Perform trace POP SCERCL E3.1.3 FTERBR SELBRA SCERCL,(TSALF,FAIL,RTNUL3) *_ *---------------------------------------------------------------------* TITLE 'Data' DTLIST DESCR DTLIST,TTL+MARK,DTLEND-DTLIST-DESCR DESCR 0,0,S DESCR VARSP,0,0 STRING DESCR 0,0,I DESCR INTGSP,0,0 INTEGER DESCR 0,0,P DESCR PATSP,0,0 PATTERN DESCR 0,0,A DESCR ARRSP,0,0 ARRAY DESCR 0,0,R DESCR RLSP,0,0 REAL DESCR 0,0,C DESCR CODESP,0,0 CODE DESCR 0,0,N DESCR NAMESP,0,0 NAME DESCR 0,0,K DESCR NAMESP,0,0 NAME (for keyword) DESCR 0,0,E DESCR EXPSP,0,0 EXPRESSION DESCR 0,0,T DESCR ASSCSP,0,0 TABLE DTLEND LHERE , * KNLIST DESCR KNLIST,TTL+MARK,KNEND-KNLIST-DESCR TRIMCL DESCR 0,0,I &TRIM DESCR TRMSP,0,0 TRAPCL DESCR 0,0,I &TRACE DESCR TRCESP,0,0 EXLMCL DESCR 50000,0,I &STLIMIT DESCR STLMSP,0,0 OUTSW DESCR 1,0,I &OUTPUT DESCR OUTSP,0,0 MLENCL DESCR 5000,0,I &MAXLNGTH DESCR MAXLSP,0,0 INSW DESCR 1,0,I &INPUT DESCR INSP,0,0 FULLCL DESCR 0,0,I &FULLSCAN DESCR FULLSP,0,0 TRACL DESCR 0,0,I &FTRACE DESCR FTRCSP,0,0 ERRLCL DESCR 0,0,I &ERRLIMIT DESCR ERRLSP,0,0 DMPCL DESCR 0,0,I &DUMP DESCR DUMPSP,0,0 RETCOD DESCR 0,0,I &CODE DESCR CODESP,0,0 ANCCL DESCR 0,0,I &ANCHOR DESCR ANCHSP,0,0 ABNDCL DESCR 0,0,I &ABEND DESCR ABNDSP,0,0 KNEND LHERE , * KVLIST DESCR KVLIST,TTL+MARK,KVEND-KVLIST-DESCR ERRTYP DESCR 0,0,I &ERRTYPE ERRTKY DESCR ERRTSP,0,0 ARBPAT DESCR ARBPT,0,P &ARB ARBKY DESCR ARBSP,0,0 BALPAT DESCR BALPT,0,P &BAL BALKY DESCR BALSP,0,0 FNCPAT DESCR FNCEPT,0,P &FENCE FNCEKY DESCR FNCESP,0,0 ABOPAT DESCR ABORPT,0,P &ABORT ABRTKY DESCR ABORSP,0,0 FALPAT DESCR FAILPT,0,P &FAIL FAILKY DESCR FAILSP,0,0 REMPAT DESCR REMPT,0,P &REM REMKY DESCR REMSP,0,0 SUCPAT DESCR SUCCPT,0,P &SUCCEED SUCCKY DESCR SUCCSP,0,0 FALCL DESCR 0,0,I &STFCOUNT FALKY DESCR STFCSP,0,0 LSTNCL DESCR 0,0,I &LASTNO DESCR LSTNSP,0,0 RETPCL DESCR 0,0,S &RTNTYPE DESCR RTYPSP,0,0 STNOCL DESCR 0,0,I &STNO DESCR STNOSP,0,0 ALPHVL DESCR 0,0,0 &ALPHABET DESCR ALNMSP,0,0 EXNOCL DESCR 0,0,I &STCOUNT STCTKY DESCR STCTSP,0,0 LVLCL DESCR 0,0,I &FNCLEVEL FNCLKY DESCR FNCLSP,0,0 KVEND LHERE , * INLIST DESCR INLIST,TTL+MARK,2*DESCR DESCR INPUT-DESCR,0,0 INPUT block DESCR INSP,0,0 OTLIST DESCR OTLIST,TTL+MARK,4*DESCR DESCR OUTPUT-DESCR,0,0 OUTPUT block DESCR OUTSP,0,0 DESCR PUNCH-DESCR,0,0 PUNCH block DESCR PNCHSP,0,0 OTSATL DESCR OTSATL,TTL+MARK,4*DESCR OUTPUT DESCR UNITO,0,I OUTPUT unit DESCR OUTPSP,0,0 OUTPUT format PUNCH DESCR UNITP,0,I PUNCH unit PCHFST DESCR CRDFSP,0,0 PUNCH format INSATL DESCR INSATL,TTL+MARK,2*DESCR INPUT DESCR UNITI,0,I INPUT unit DFLSIZ DESCR 80,0,I INPUT length * TRLIST DESCR TRLIST,TTL+MARK,10*DESCR DESCR TVALL,0,0 VALUE trace VALTRS DESCR VALSP,0,0 DESCR TLABL,0,0 LABEL trace DESCR TRLASP,0,0 TFNCLP DESCR TFENTL,0,0 CALL trace DESCR TRFRSP,0,0 TFNRLP DESCR TFEXTL,0,0 RETURN trace DESCR RETSP,0,0 DESCR TKEYL,0,0 KEYWORD trace DESCR TRKYSP,0,0 * TRCBLK DESCR TRCBLK,TTL+MARK,5*DESCR V3.7 DESCR 0,FNC,2 TRACE FUNCTION DESCRIPTOR V3.7 LIT1CL DESCR LITFN,FNC,1 LITERAL FUNCTION DESCRIPTOR E3.7.1 DESCR 0,0,0 VARIABLE TO BE TRACED V3.7 DESCR LITFN,FNC,1 LITERAL FUNCTION DESCRIPTOR E3.7.1 DESCR 0,0,0 TAG SUPPLIED FOR TRACE V3.7 * ATRHD DESCR ATPRCL-DESCR,0,0 Array header converting from TABLE ATPRCL DESCR 0,0,0 Prototype DESCR 2,0,0 Dimensionality DESCR 1,0,2 1:2 second dimension ATEXCL DESCR 1,0,0 1:n first dimension * * Data type pairs * ATDTP DESCR A,0,T ARRAY-TABLE IIDTP DESCR I,0,I INTEGER-INTEGER IPDTP DESCR I,0,P INTEGER-PATTERN IRDTP DESCR I,0,R INTEGER-REAL IVDTP DESCR I,0,S INTEGER-STRING PIDTP DESCR P,0,I PATTERN-INTEGER PPDTP DESCR P,0,P PATTERN-PATTERN PVDTP DESCR P,0,S PATTERN-STRING RIDTP DESCR R,0,I REAL-INTEGER RPDTP DESCR R,0,P REAL-PATTERN RRDTP DESCR R,0,R REAL-REAL RVDTP DESCR R,0,S REAL-STRING TADTP DESCR T,0,A TABLE-ARRAY VCDTP DESCR S,0,C STRING-CODE VEDTP DESCR S,0,E STRING-EXPRESSION VIDTP DESCR S,0,I STRING-INTEGER VPDTP DESCR S,0,P STRING-PATTERN VRDTP DESCR S,0,R STRING-REAL VVDTP DESCR S,0,S STRING-STRING * ARTHCL DESCR 0,0,0 Number of arithmetic operations CSTNCL DESCR 0,0,I Compiler statement number RSTAT DESCR 0,0,0 Number of reads SCNCL DESCR 0,0,0 Number of scanner entrances WSTAT DESCR 0,0,0 Number of writes TIMECL DESCR 0,0,0 Millisecond time * * SWITCHES * ALCL DESCR 0,0,0 Entry point switch for ARG(F,N) ARRMRK DESCR 0,0,0 Prototype end switch for ARRAY(P,V) CUTNO DESCR 0,0,0 E3.2.2 CNSLCL DESCR 0,0,0 Label redefinition switch DATACL DESCR 0,0,0 Prototype end switch for DATA(P) FNVLCL DESCR 0,0,0 FUNCTION-VALUE switch for trace INICOM DESCR 0,0,0 INITIALIZATION SWITCH E3.10.6 LENFCL DESCR 0,0,0 Length failure switch LISTCL DESCR 1,0,0 Compiler listing switch LLIST DESCR 0,0,0 Left listing switch NAMGCL DESCR 0,0,0 Naming switch for SJSR SCERCL DESCR 0,0,0 Error branch switch * * Constants * ARBSIZ DESCR 8*NODESZ,0,0 Node size for ARBNO(P) CHARCL DESCR 1,0,0 Length constant 1 CNDSIZ DESCR CNODSZ,0,B Compiler node size CODELT DESCR 200*DESCR,0,C Object code excess DSCRTW DESCR 2*DESCR,0,0 Constant 2*DESCR EOSCL DESCR EOSTYP,0,0 End of statement switch ESALIM DESCR ESASIZ*DESCR,0,0 Bound on compilation errors EXTVAL DESCR EXTSIZ*2*DESCR,0,0 V3.11 FBLKRQ DESCR FBLKSZ,0,B Quantum on allocated function blocks GOBRCL DESCR 0,0,0 Goto break character switch GTOCL DESCR FGOTYP,0,0 Goto decision switch IOBLSZ DESCR 2*DESCR,0,B Size of I/O blocks LNODSZ DESCR NODESZ+DESCR,0,P Size of long pattern node NODSIZ DESCR NODESZ,0,P Size of short pattern node OBEND DESCR OBLIST+DESCR*OBOFF,0,0 * End on bin list OCALIM DESCR OCASIZ*DESCR,0,C Size of object code block ONECL DESCR 1,0,0 Constant 1 OUTBLK DESCR OUTPUT-DESCR,0,0 Pointer to OUTPUT block SIZLMT DESCR SIZLIM,0,0 Limit on size of data object SNODSZ DESCR NODESZ,0,P Small pattern node size STARSZ DESCR 11*DESCR,0,P Size of EXPRESSION pattern ZEROCL DESCR 0,0,0 Constant zero TRSKEL DESCR TRCBLK,0,0 COMDCT DESCR 14*DESCR,0,0 COMREG DESCR ELEMND,0,0 Pointer to compiler descriptors * * * * Pointers to Assembled Data Patterns * ARBACK DESCR ARBAK,0,P ARHEAD DESCR ARHED,0,P ARTAIL DESCR ARTAL,0,P STRPAT DESCR STARPT,0,P * * Function Descriptors * ANYCCL DESCR ANYCFN,FNC,3 ASGNCL DESCR ASGNFN,FNC,2 ATOPCL DESCR ATOPFN,FNC,3 BASECL DESCR BASEFN,FNC,0 BRKCCL DESCR BRKCFN,FNC,3 CHRCL DESCR CHRFN,FNC,3 CONCL DESCR CONFN,FNC,0 Argument count is incremented DNMECL DESCR DNMEFN,FNC,2 DNMICL DESCR DNMIFN,FNC,2 ENDCL DESCR ENDFN,FNC,0 ENMECL DESCR ENMEFN,FNC,3 ENMICL DESCR ENMIFN,FNC,3 ERORCL DESCR ERORFN,FNC,1 FNCFCL DESCR FNCFFN,FNC,2 FNMECL DESCR FNMEFN,FNC,2 GOTGCL DESCR GOTGFN,FNC,1 GOTLCL DESCR GOTLFN,FNC,1 GOTOCL DESCR GOTOFN,FNC,1 INITCL DESCR INITFN,FNC,1 ITEMCL DESCR AREFN,FNC,0 LITCL DESCR LITFN,FNC,0 Argument count is incremented LNTHCL DESCR LNTHFN,FNC,3 NMECL DESCR NMEFN,FNC,2 NNYCCL DESCR NNYCFN,FNC,3 POSICL DESCR POSIFN,FNC,3 RPSICL DESCR RPSIFN,FNC,3 RTBCL DESCR RTBFN,FNC,3 SCANCL DESCR SCANFN,FNC,2 SCFLCL DESCR SCFLFN,FNC,2 SCOKCL DESCR SCOKFN,FNC,2 SCONCL DESCR SCONFN,FNC,2 SJSRCL DESCR SJSRFN,FNC,3 SPNCCL DESCR SPNCFN,FNC,3 SUCFCL DESCR SUCFFN,FNC,2 TBCL DESCR TBFN,FNC,3 INITB DESCR ABNDB,0,0 INITE DESCR DTEND+DESCR,0,0 * * Miscellaneous Data Cells * A4PTR DESCR 0,0,0 Scratch descriptor A5PTR DESCR 0,0,0 Scratch descriptor A6PTR DESCR 0,0,0 Scratch descriptor A7PTR DESCR 0,0,0 Scratch descriptor BRTYPE DESCR 0,0,0 Break type returned by FORWRD CMOFCL DESCR 0,0,0 Compiler offset DATSEG DESCR 0,0,100 Beginning of defined data types DMPPTR DESCR 0,0,0 Bin pointer for DUMP DTCL DESCR 0,0,0 Data type descriptor DT1CL DESCR 0,0,0 Data type descriptor EMSGCL DESCR 0,0,0 Present error message address ERRBAS DESCR CARDSZ+STNOSZ-SEQSIZ,0,0 ESAICL DESCR 0,0,0 Count of compiler errors ETMCL DESCR 0,0,0 Time descriptor FCL DESCR 0,0,0 Real number descriptor NEXFCL DESCR FBLKSZ,0,0 Offset in function block FRTNCL DESCR 0,0,0 Failure return GOGOCL DESCR 0,0,0 goto descriptor INCL DESCR 0,0,0 Global function descriptor IOKEY DESCR 0,0,0 I/O indicator MAXLEN DESCR 0,0,0 Maximum length for matching MSGNO DESCR MSGLST,0,0 Pointer to error message list NAMICL DESCR 0,0,0 Offset on naming list NHEDCL DESCR 0,0,0 Name list head offset NMOVER DESCR NAMLSZ*SPDR,0,B Name list end offset NULVCL DESCR 0,0,S Null string value OCICL DESCR 0,0,0 Object code offset PATICL DESCR 0,0,0 Pattern code offset PDLEND DESCR PDLBLK+SPDLDR-NODESZ,0,0 * Pattern history list end PDLPTR DESCR PDLBLK,0,0 Pattern history list beginning SCL DESCR 0,0,0 Switch descriptor STKPTR DESCR STACK,0,0 Pointer to stack STYPE DESCR 0,FNC,0 Descriptor return by STREAM TBLFNC DESCR 0,0,0 Pointer to last pattern table UNIT DESCR 0,0,0 Input unit switch VARSYM DESCR 0,0,0 * * Program Pointers * DATCL DESCR DEFDAT,FNC,0 Defined data objects DEFCL DESCR DEFFNC,FNC,0 Defined functions FLDCL DESCR FIELD,0,1 Field of defined data objects LODCL DESCR LNKFNC,FNC,0 External functions PDLHED DESCR PDLBLK,0,0 History list head UNDFCL DESCR UNDF,FNC,0 Undefined functions * * Pointers to Specifiers * DPSPTR DESCR DPSP,0,0 XSPPTR DESCR XSP,0,0 YSPPTR DESCR YSP,0,0 ZSPPTR DESCR ZSP,0,0 TSPPTR DESCR TSP,0,0 * * Permanent Attribute List Pointers * KNATL DESCR KNLIST,0,0 Unprotected keyword list KVATL DESCR KVLIST,0,0 Protected keyword list TRATL DESCR TRLIST,0,0 Trace list * * Specifiers for Compilation Listing * BLNSP SPEC BLNBUF,0,0,0,STNOSZ ERRSP SPEC ERRBUF,0,0,0,CARDSZ+STNOSZ-SEQSIZ+1 INBFSP SPEC INBUF,0,0,STNOSZ,CARDSZ LNBFSP SPEC INBUF,0,0,0,CARDSZ+DSTSZ+1 NEXTSP SPEC INBUF,0,0,STNOSZ,CARDSZ-SEQSIZ LNOSP SPEC INBUF,0,0,0,STNOSZ RNOSP SPEC INBUF,0,0,CARDSZ+STNOSZ+1,STNOSZ * * Strings and Specifiers * ALPHSP SPEC ALPHA,0,0,0,ALPHSZ Alphabet AMPSP SPEC AMPST,0,0,0,1 Ampersand CERRSP SPEC ANYSP,0,0,0,0 Buffer specifier COLSP SPEC COLSTR,0,0,0,2 Colon for trace messages DMPSP SPEC ANYSP,0,0,0,0 Buffer specifier DTARSP SPEC DTARBF,0,0,0,ARRLEN+9 * Array representation specifier PROTSP SPEC ANYSP,0,0,0,0 Buffer specifier QTSP SPEC QTSTR,0,0,0,1 Quote for messages REALSP SPEC REALBF,0,0,0,10 Specifier for real conversion TRACSP SPEC ANYSP,0,0,0,0 Buffer specifier * ARRSP STRING 'ARRAY' ASSCSP STRING 'TABLE' BLSP STRING ' ' BLEQSP STRING ' = ' CMASP STRING ',' EJCTSP STRING 'EJECT' EQLSP STRING '= ' ETIMSP STRING ',TIME = ' EXDTSP STRING 'EXTERNAL' LEFTSP STRING 'LEFT' LISTSP STRING 'LIST' LPRNSP STRING '(' OFSP STRING ' OF ' RPRNSP STRING ')' STARSP STRING '*** ' TRCLSP STRING ' CALL OF ' TRLVSP STRING 'LEVEL ' TRSTSP STRING ' STATEMENT ' UNLSP STRING 'UNLIST' XFERSP STRING 'TRANSFER TO' * * Character Buffers * BLNBUF BUFFER STNOSZ Blanks for statment number field DTARBF BUFFER ARRLEN+7 Array representation buffer ERRBUF BUFFER CARDSZ+STNOSZ-SEQSIZ+1 INBUF BUFFER CARDSZ+DSTSZ+1 Card input buffer REALBF BUFFER 36 Buffer for real number conversion ICLBLK DESCR ICLBLK,TTL+MARK,ICLEND-ICLBLK-DESCR * * Pointers to Attribute Lists * DTATL DESCR DTLIST,0,0 Data type pair list FNCPL DESCR FNLIST,0,0 Function pair list INATL DESCR INLIST,0,0 Input association pair list OUTATL DESCR OTLIST,0,0 Output association pair list TVALL DESCR TVALPL,0,0 Value trace pair list DESCR VLTRFN,FNC,2 Default value trace procedure TLABL DESCR TLABPL,0,0 Label trace pair list DESCR LABTFN,FNC,1 Default label trace procedure TFENTL DESCR TFENPL,0,0 Call trace pair list DESCR FNTRFN,FNC,2 Default call trace procedure TFEXTL DESCR TFEXPL,0,0 Return trace pair list DESCR FXTRFN,FNC,2 Default return trace procedure TKEYL DESCR TKEYPL,0,0 Keyword trace pair list DESCR KEYTFN,FNC,1 Default keyword trace procedure * * Scratch Descriptors * A1PTR DESCR 0,0,0 A2PTR DESCR 0,0,0 A3PTR DESCR 0,0,0 ATPTR DESCR 0,0,0 F1PTR DESCR 0,0,0 F2PTR DESCR 0,0,0 IO2PTR DESCR 0,0,0 IO1PTR DESCR 0,0,0 LPTR DESCR 0,0,0 Last label pointer NVAL DESCR 0,0,0 IO3PTR DESCR 0,0,0 IO4PTR DESCR 0,0,0 TBLCS DESCR 0,0,0 TMVAL DESCR 0,0,0 TPTR DESCR 0,0,0 TCL DESCR 0,0,0 TSIZ DESCR 0,0,0 TVAL DESCR 0,0,0 VVAL DESCR 0,0,0 WCL DESCR 0,0,0 WPTR DESCR 0,0,0 XCL DESCR 0,0,0 XPTR DESCR 0,0,0 XSIZ DESCR 0,0,0 YCL DESCR 0,0,0 YPTR DESCR 0,0,0 YSIZ DESCR 0,0,0 ZCL DESCR 0,0,0 ZPTR DESCR 0,0,0 ZSIZ DESCR 0,0,0 * * System Descriptors * BOSCL DESCR 0,0,0 Offset of beginning of statement CMBSCL DESCR 0,0,0 Compiler code base descriptor NBSPTR DESCR 0,0,0 Name list base pointer FBLOCK DESCR 0,0,0 Function procedure descriptor block OCBSCL DESCR 0,0,0 Interpreter code base descriptor OCLIM DESCR 0,0,0 End of object code block OCSVCL DESCR 0,0,0 Pointer to basic object code PATBCL DESCR 0,0,0 Pattern code base descriptor SCBSCL DESCR 0,0,0 SRNCL DESCR 0,0,0 Success return descriptor * * Compiler Descriptors * ELEMND DESCR 0,0,0 Element node ELEXND DESCR 0,0,0 Temporary node ELEYND DESCR 0,0,0 Temporary node EXELND DESCR 0,0,0 Temporary node EXEXND DESCR 0,0,0 Temporary node EXOPCL DESCR 0,0,0 Operator node EXOPND DESCR 0,0,0 Operator node EXPRND DESCR 0,0,0 Expression node FGOND DESCR 0,0,0 Failure goto node FORMND DESCR 0,0,0 Object node FRNCL DESCR 0,0,0 Failure return descriptor GOTOND DESCR 0,0,0 Goto node PATND DESCR 0,0,0 Pattern node SGOND DESCR 0,0,0 Success goto node SUBJND DESCR 0,0,0 Subject node * * Data Pointers * DFLFST DESCR 0,0,0 Default output format ENDPTR DESCR 0,0,0 'END' EXTPTR DESCR 0,0,0 'EXTERNAL' FRETCL DESCR 0,0,0 'FRETURN' NRETCL DESCR 0,0,0 'NRETURN' RETCL DESCR 0,0,0 'RETURN' FUNTCL DESCR 0,0,0 'FUNCTION' * * Specifiers * DPSP SPEC 0,0,0,0,0 Data type specifier HEADSP SPEC 0,0,0,0,0 Matching head specifier IOSP SPEC 0,0,0,0,0 I/O specifier TAILSP SPEC 0,0,0,0,0 Matching tail specifier TEXTSP SPEC 0,0,0,0,0 Compiler statement specifier TSP SPEC 0,0,0,0,0 Scratch specifier TXSP SPEC 0,0,0,0,0 Scratch specifier VSP SPEC 0,0,0,0,0 Scratch specifier XSP SPEC 0,0,0,0,0 Scratch specifier YSP SPEC 0,0,0,0,0 Scratch specifier ZSP SPEC 0,0,0,0,0 Scratch specifier * * Allocator Data * ARG1CL DESCR 0,0,0 Scratch descriptor BUKPTR DESCR 0,PTR,S Bin pointer LSTPTR DESCR 0,PTR,S Pointer to last structure AXPTR DESCR 0,0,0 Allocation size descriptor SPECR1 SPEC 0,0,0,0,0 Scratch specifier SPECR2 SPEC 0,0,0,0,0 Scratch specifier ICLEND LHERE , End of basic block * * Allocator Data * BK1CL DESCR 0,0,0 Pointer to block being marked BKDX DESCR 0,0,0 Offset in block being marked BKDXU DESCR 0,0,0 Offset in block BKLTCL DESCR 0,0,0 BKPTR DESCR 0,PTR,S BLOCL DESCR 0,0,0 CONVSW DESCR 0,0,0 CONVAR-GENVAR entry switch CPYCL DESCR 0,0,0 Regeneration block pointer DESCL DESCR 0,0,0 Regeneration scratch descriptor EQUVCL DESCR 0,0,0 Variable identification descriptor FRDSCL DESCR 4*DESCR,0,0 GCBLK DESCR GCXTTL,0,0 Pointer to marking block GCNO DESCR 0,0,0 Count of regenerations GCMPTR DESCR 0,0,0 Pointer to basic blocks GCREQ DESCR 0,0,0 Space required from regeneration GCGOT DESCR 0,0,I Space obtained from regeneration LCPTR DESCR 0,0,0 Scratch descriptor MVSGPT DESCR 0,0,0 Compression boundary pointer NODPCL DESCR 0,0,0 Regeneration switch OBPTR DESCR OBLIST,PTR,S Pointer to bins OFSET DESCR 0,0,0 Offset in block during regeneration PRMDX DESCR PRMSIZ,0,0 Size of basic block list PRMPTR DESCR PRMTBL,0,0 Pointer to list of basic blocks ST1PTR DESCR 0,PTR,S Regeneration link pointer ST2PTR DESCR 0,PTR,S Regeneration link pointer TEMPCL DESCR 0,PTR,0 Scracth descriptor TOPCL DESCR 0,0,0 Pointer to block title TTLCL DESCR 0,0,0 Pointer to block title TWOCL DESCR 2*DESCR,0,B Size of string to be marked * * FRSGPT DESCR 0,PTR,0 Position pointer HDSGPT DESCR 0,PTR,0 Head of allocated data region TLSGP1 DESCR 0,PTR,0 End of allocated data region GCXTTL DESCR GCXTTL,TTL+MARK,DESCR * Block to prime marking procedure DESCR 0,0,0 Pointer to block to mark * * Machine-dependent Data * COPY MDATA Segment of machine-dependent data * * Function Table * FTABLE DESCR FTABLE,TTL+MARK,FTBLND-FTABLE-DESCR * * Primitive Functions * ANYFN DESCR ANY,0,1 DESCR 0,0,0 APLYFN DESCR APPLY,FNC,1 DESCR 0,0,0 ARBOFN DESCR ARBNO,0,1 DESCR 0,0,0 ARGFN DESCR ARG,0,2 DESCR 0,0,0 ARRAFN DESCR ARRAY,0,2 DESCR 0,0,0 ASSCFN DESCR ASSOC,0,2 DESCR 0,0,0 BACKFN DESCR BKSPCE,0,1 DESCR 0,0,0 BREAFN DESCR BREAK,0,1 DESCR 0,0,0 CLEAFN DESCR CLEAR,0,1 DESCR 0,0,0 CODEFN DESCR CODER,0,1 DESCR 0,0,0 COLEFN DESCR COLECT,0,1 DESCR 0,0,0 CNVRFN DESCR CNVRT,0,2 DESCR 0,0,0 COPYFN DESCR COPY,0,1 DESCR 0,0,0 DATFN DESCR DATE,0,1 DESCR 0,0,0 DATDFN DESCR DATDEF,0,1 DESCR 0,0,0 DEFIFN DESCR DEFINE,0,2 DESCR 0,0,0 DIFFFN DESCR DIFFER,0,2 DESCR 0,0,0 DTCHFN DESCR DETACH,0,1 DESCR 0,0,0 DTFN DESCR DT,0,1 DESCR 0,0,0 DUMPFN DESCR DMP,0,1 DESCR 0,0,0 DUPLFN DESCR DUPL,0,2 DESCR 0,0,0 ENDFFN DESCR ENFILE,0,1 DESCR 0,0,0 EQFN DESCR EQ,0,2 DESCR 0,0,0 EVALFN DESCR EVAL,0,1 DESCR 0,0,0 FLDSFN DESCR FIELDS,0,2 DESCR 0,0,0 GEFN DESCR GE,0,2 DESCR 0,0,0 GTFN DESCR GT,0,2 DESCR 0,0,0 IDENFN DESCR IDENT,0,2 DESCR 0,0,0 INTGFN DESCR INTGER,0,1 DESCR 0,0,0 ITEMFN DESCR ITEM,FNC,1 DESCR 0,0,0 LEFN DESCR LE,0,2 DESCR 0,0,0 LENFN DESCR LEN,0,1 DESCR 0,0,0 LGTFN DESCR LGT,0,2 DESCR 0,0,0 LOADFN DESCR LOAD,0,2 DESCR 0,0,0 LOCFN DESCR LOCAL,0,2 DESCR 0,0,0 LTFN DESCR LT,0,2 DESCR 0,0,0 NEFN DESCR NE,0,2 DESCR 0,0,0 NOTAFN DESCR NOTANY,0,1 DESCR 0,0,0 OPSYFN DESCR OPSYN,0,3 DESCR 0,0,0 POSFN DESCR POS,0,1 DESCR 0,0,0 PRINFN DESCR PRINT,0,3 DESCR 0,0,0 PROTFN DESCR PROTO,0,1 DESCR 0,0,0 REMDFN DESCR REMDR,0,2 DESCR 0,0,0 RPLAFN DESCR RPLACE,0,3 DESCR 0,0,0 READFN DESCR READ,0,3 DESCR 0,0,0 REWNFN DESCR REWIND,0,1 DESCR 0,0,0 RPOSFN DESCR RPOS,0,1 DESCR 0,0,0 RTABFN DESCR RTAB,0,1 DESCR 0,0,0 SIZEFN DESCR SIZE,0,1 DESCR 0,0,0 SPANFN DESCR SPAN,0,1 DESCR 0,0,0 STPTFN DESCR STOPTR,0,2 DESCR 0,0,0 TABFN DESCR TAB,0,1 DESCR 0,0,0 TIMFN DESCR TIME,0,1 DESCR 0,0,0 TRCEFN DESCR TRACE,0,4 DESCR 0,0,0 TRIMFN DESCR TRIM,0,1 DESCR 0,0,0 UNLDFN DESCR UNLOAD,0,1 DESCR 0,0,0 VALFN DESCR FIELD,0,1 DESCR VALBLK,0,0 FTBLND LHERE , * INITLS DESCR INITLS,TTL+MARK,8*DESCR DESCR DTLIST,0,0 DESCR FNLIST,0,0 DESCR INLIST,0,0 DESCR KNLIST,0,0 DESCR KVLIST,0,0 DESCR OTLIST,0,0 DESCR OTSATL,0,0 DESCR TRLIST,0,0 * * Function Pair List * FNLIST DESCR FNLIST,TTL+MARK,FNCPLE-FNLIST-DESCR DESCR ANYFN,FNC,0 ANY(CS) DESCR ANYSP,0,0 DESCR APLYFN,FNC,0 APPLY(F,A1,...,AN) DESCR APLYSP,0,0 DESCR ARBOFN,FNC,0 ARBNO(P) DESCR ARBNSP,0,0 DESCR ARGFN,FNC,0 ARG(F,N) DESCR ARGSP,0,0 DESCR ARRAFN,FNC,0 ARRAY(P,V) DESCR ARRSP,0,0 DESCR BACKFN,FNC,0 BACKSPACE(N) DESCR BACKSP,0,0 DESCR BREAFN,FNC,0 BREAK(CS) DESCR BRKSP,0,0 DESCR CLEAFN,FNC,0 CLEAR() DESCR CLERSP,0,0 DESCR CODEFN,FNC,0 CODE(S) DESCR CODESP,0,0 DESCR COLEFN,FNC,0 COLLECT(N) DESCR CLSP,0,0 DESCR CNVRFN,FNC,0 CONVERT(V,DT) DESCR CNVTSP,0,0 DESCR COPYFN,FNC,0 COPY(V) DESCR COPYSP,0,0 DESCR DATDFN,FNC,0 DATA(P) DESCR DATASP,0,0 DESCR DATFN,FNC,0 E3.0.5 DESCR DATSP,0,0 DESCR DEFIFN,FNC,0 DEFINE(P,L) DESCR DEFISP,0,0 DESCR DIFFFN,FNC,0 DIFFER(V1,V2) DESCR DIFFSP,0,0 DESCR DTCHFN,FNC,0 DETACH(V) DESCR DTCHSP,0,0 DESCR DTFN,FNC,0 DATATYPE(V) DESCR DTSP,0,0 DESCR DUMPFN,FNC,0 DUMP() DESCR DUMPSP,0,0 DESCR DUPLFN,FNC,0 DUPL(S,N) DESCR DUPLSP,0,0 DESCR ENDFFN,FNC,0 ENDFILE(N) DESCR ENDFSP,0,0 DESCR EQFN,FNC,0 EQ(I1,I2) DESCR EQSP,0,0 DESCR EVALFN,FNC,0 EVAL(E) DESCR EVALSP,0,0 DESCR FLDSFN,FNC,0 FIELD(V,N) DESCR FLDSSP,0,0 DESCR GEFN,FNC,0 GE(I1,I2) DESCR GESP,0,0 DESCR GTFN,FNC,0 GT(I1,I2) DESCR GTSP,0,0 DESCR IDENFN,FNC,0 IDENT(V1,V2) DESCR IDENSP,0,0 DESCR READFN,FNC,0 INPUT(V,N,L) DESCR INSP,0,0 DESCR INTGFN,FNC,0 INTEGER(V) DESCR INTGSP,0,0 DESCR ITEMFN,FNC,0 ITEM(A,I1,...,IN) DESCR ITEMSP,0,0 DESCR LENFN,FNC,0 LEN(N) DESCR LENSP,0,0 DESCR LEFN,FNC,0 LE(I1,I2) DESCR LESP,0,0 DESCR LGTFN,FNC,0 LGT(S1,S2) DESCR LGTSP,0,0 DESCR LOADFN,FNC,0 LOAD(P) DESCR LOADSP,0,0 DESCR LOCFN,FNC,0 LOCAL(F,N) DESCR LOCSP,0,0 DESCR LTFN,FNC,0 LT(I1,I2) DESCR LTSP,0,0 DESCR NEFN,FNC,0 NE(I1,I2) DESCR NESP,0,0 DESCR NOTAFN,FNC,0 NOTANY(CS) DESCR NNYSP,0,0 DESCR OPSYFN,FNC,0 OPSYN(F1,F2,N) DESCR OPSNSP,0,0 DESCR PRINFN,FNC,0 OUTPUT(V,N,F) DESCR OUTSP,0,0 DESCR POSFN,FNC,0 POS(N) DESCR POSSP,0,0 DESCR PROTFN,FNC,0 PROTOTYPE(A) DESCR PRTSP,0,0 DESCR REMDFN,FNC,0 REMDR(N,M) DESCR REMDSP,0,0 DESCR REWNFN,FNC,0 REWIND(N) DESCR REWNSP,0,0 DESCR RPLAFN,FNC,0 REPLACE(S,CS1,CS2) DESCR RPLCSP,0,0 DESCR RPOSFN,FNC,0 RPOS(N) DESCR RPOSSP,0,0 DESCR RTABFN,FNC,0 RTAB(N) DESCR RTABSP,0,0 DESCR SIZEFN,FNC,0 SIZE(S) DESCR SIZESP,0,0 DESCR SPANFN,FNC,0 SPAN(CS) DESCR SPANSP,0,0 DESCR STPTFN,FNC,0 STOPTR(V,R) DESCR STPTSP,0,0 DESCR TABFN,FNC,0 TAB(N) DESCR TABSP,0,0 DESCR ASSCFN,FNC,0 TABLE(N,M) DESCR ASSCSP,0,0 DESCR TIMFN,FNC,0 TIME() DESCR TIMSP,0,0 DESCR TRCEFN,FNC,0 TRACE(V,R,T,F) DESCR TRCESP,0,0 DESCR TRIMFN,FNC,0 TRIM(S) DESCR TRMSP,0,0 DESCR UNLDFN,FNC,0 UNLOAD(S) DESCR UNLDSP,0,0 DESCR VALFN,FNC,0 VALUE(S) DESCR VALSP,0,0 ARRAY 10*2 Space for 10 more functions FNCPLE LHERE , End of function pair list OPTBL DESCR OPTBL,TTL+MARK,OPTBND-OPTBL-DESCR ADDFN DESCR ADD,0,2 X + Y addition DESCR 0,0,0 DESCR 30,0,29 BIAMFN DESCR UNDF,FNC,0 X & Y definable DESCR 0,0,0 DESCR 5,0,4 BIATFN DESCR UNDF,FNC,0 X @ Y definable DESCR 0,0,0 DESCR 25,0,24 BINGFN DESCR UNDF,FNC,0 X \ Y definable DESCR 0,0,0 DESCR 70,0,70 BIPDFN DESCR UNDF,FNC,0 X # Y definable DESCR 0,0,0 DESCR 35,0,34 BIPRFN DESCR UNDF,FNC,0 X % Y definable DESCR 0,0,0 DESCR 45,0,44 BIQSFN DESCR UNDF,FNC,0 X ? Y definable DESCR 0,0,0 DESCR 70,0,69 CONFN DESCR CON,0,2 X Y concatenation DESCR 0,0,0 DESCR 20,0,19 DIVFN DESCR DIV,0,2 X / Y division DESCR 0,0,0 DESCR 40,0,39 DOLFN DESCR DOL,0,2 X $ Y immediate naming DESCR 0,0,0 DESCR 60,0,59 EXPFN DESCR EXP,0,2 X ** Y exponentiation DESCR 0,0,0 DESCR 50,0,50 MPYFN DESCR MPY,0,2 X * Y multiplication DESCR 0,0,0 DESCR 42,0,41 NAMFN DESCR NAM,0,2 X . Y naming DESCR 0,0,0 DESCR 60,0,59 ORFN DESCR OR,0,2 X | Y alternation DESCR 0,0,0 DESCR 10,0,9 SUBFN DESCR SUB,0,2 X - Y subtraction DESCR 0,0,0 DESCR 30,0,29 AROWFN DESCR UNDF,FNC,0 !X definable DESCR 0,0,0 ATFN DESCR ATOP,0,1 @X scanner position DESCR 0,0,0 BARFN DESCR UNDF,FNC,0 |X definable DESCR 0,0,0 DOTFN DESCR NAME,0,1 .X name DESCR 0,0,0 INDFN DESCR IND,0,1 $X indirect reference DESCR 0,0,0 KEYFN DESCR KEYWRD,0,1 &X keyword DESCR 0,0,0 MNSFN DESCR MNS,0,1 -X minus DESCR 0,0,0 NEGFN DESCR NEG,0,1 \X negation DESCR 0,0,0 PDFN DESCR UNDF,FNC,0 #X definable DESCR 0,0,0 PLSFN DESCR PLS,0,1 +X plus DESCR 0,0,0 PRFN DESCR UNDF,FNC,0 %X definable DESCR 0,0,0 QUESFN DESCR QUES,0,1 ?X interrogation DESCR 0,0,0 SLHFN DESCR UNDF,FNC,0 /X definable DESCR 0,0,0 STRFN DESCR STR,0,1 *X unevaluated expression DESCR 0,0,0 OPTBND LHERE , End of operator table * * AREFN DESCR ITEM,FNC,1 Array or table reference ASGNFN DESCR ASGN,0,2 X = Y BASEFN DESCR BASE,0,0 Base object code ENDAFN DESCR ARGNER,0,0 Safety exit on trace psuedo-code ENDFN DESCR END,0,0 End of program ERORFN DESCR EROR,0,1 Erroneous statement FNTRFN DESCR FENTR,0,2 Call tracing FXTRFN DESCR FNEXTR,0,2 Return tracing GOTGFN DESCR GOTG,0,1 :<X> GOTLFN DESCR GOTL,0,1 :(L) GOTOFN DESCR GOTO,0,1 Internal goto INITFN DESCR INIT,0,1 Statement initialization KEYTFN DESCR KEYTR,0,2 Keyword tracing LABTFN DESCR LABTR,0,2 Label tracing LITFN DESCR LIT,0,1 Literal evaluation SCANFN DESCR SCAN,0,2 Pattern matching SJSRFN DESCR SJSR,0,3 Pattern matching with replacement VLTRFN DESCR VALTR,0,2 Value tracing ANYCFN DESCR ANYC,0,3 Matching for ANY(S) ARBFFN DESCR ARBF,0,2 Failure for ARB ARBNFN DESCR ARBN,0,2 Matching for ARBNO(P) ATOPFN DESCR ATP,0,3 Matching for @X CHRFN DESCR CHR,0,3 Matching for string BALFN DESCR BAL,0,2 Matching for BAL BALFFN DESCR BALF,0,2 Failure for BAL BRKCFN DESCR BRKC,0,3 Matching for BREAK(S) DNMEFN DESCR DNME,0,2 DNMIFN DESCR DNME1,0,2 EARBFN DESCR EARB,0,2 DSARFN DESCR DSAR,0,3 ENMEFN DESCR ENME,0,3 ENMIFN DESCR ENMI,0,3 FARBFN DESCR FARB,0,2 FNMEFN DESCR FNME,0,2 LNTHFN DESCR LNTH,0,3 Matching for LEN(N) NMEFN DESCR NME,0,2 NNYCFN DESCR NNYC,0,3 Matching for NOTANY(S) ONARFN DESCR ONAR,0,2 ONRFFN DESCR ONRF,0,2 POSIFN DESCR POSI,0,3 Matching for POS(N) RPSIFN DESCR RPSI,0,3 Matching for RPOS(N) RTBFN DESCR RTB,0,3 Matching for RTAB(N) SALFFN DESCR SALF,0,2 SCFLFN DESCR FAIL,0,2 SCOKFN DESCR SCOK,0,2 Successful match procedure SCONFN DESCR SCON,0,2 SPNCFN DESCR SPNC,0,3 Matching for SPAN(S) STARFN DESCR STAR,0,3 Matching for *X TBFN DESCR TB,0,3 Matching for TAB(N) ABORFN DESCR RTNUL3,0,3 Matching for ABORT FNCEFN DESCR FNCE,0,2 Matching for FENCE FNCFFN DESCR RTNUL3,0,2 Failure for FENCE SUCFFN DESCR SUCF,0,2 Matching for SUCCEED * * Initialization Data for Functions * ABNDSP STRING 'ABEND' ABORSP STRING 'ABORT' ALNMSP STRING 'ALPHABET' ANCHSP STRING 'ANCHOR' ANYSP STRING 'ANY' APLYSP STRING 'APPLY' ARBSP STRING 'ARB' ARBNSP STRING 'ARBNO' ARGSP STRING 'ARG' BACKSP STRING 'BACKSPACE' BALSP STRING 'BAL' BRKSP STRING 'BREAK' TRFRSP STRING 'CALL' CLERSP STRING 'CLEAR' CODESP STRING 'CODE' CLSP STRING 'COLLECT' CNVTSP STRING 'CONVERT' COPYSP STRING 'COPY' DATSP STRING 'DATE' DATASP STRING 'DATA' DEFISP STRING 'DEFINE' DIFFSP STRING 'DIFFER' DTCHSP STRING 'DETACH' DTSP STRING 'DATATYPE' DUMPSP STRING 'DUMP' DUPLSP STRING 'DUPL' ENDSP STRING 'END' ENDFSP STRING 'ENDFILE' EQSP STRING 'EQ' ERRLSP STRING 'ERRLIMIT' ERRTSP STRING 'ERRTYPE' EVALSP STRING 'EVAL' EXPSP STRING 'EXPRESSION' FAILSP STRING 'FAIL' FNCESP STRING 'FENCE' FLDSSP STRING 'FIELD' FNCLSP STRING 'FNCLEVEL' FRETSP STRING 'FRETURN' FTRCSP STRING 'FTRACE' FULLSP STRING 'FULLSCAN' FUNTSP STRING 'FUNCTION' GESP STRING 'GE' GTSP STRING 'GT' IDENSP STRING 'IDENT' INSP STRING 'INPUT' INTGSP STRING 'INTEGER' ITEMSP STRING 'ITEM' TRKYSP STRING 'KEYWORD' TRLASP STRING 'LABEL' LSTNSP STRING 'LASTNO' LENSP STRING 'LEN' LESP STRING 'LE' LGTSP STRING 'LGT' LOADSP STRING 'LOAD' LOCSP STRING 'LOCAL' LTSP STRING 'LT' MAXLSP STRING 'MAXLNGTH' NAMESP STRING 'NAME' NESP STRING 'NE' NNYSP STRING 'NOTANY' NRETSP STRING 'NRETURN' OPSNSP STRING 'OPSYN' OUTSP STRING 'OUTPUT' PATSP STRING 'PATTERN' POSSP STRING 'POS' PRTSP STRING 'PROTOTYPE' PNCHSP STRING 'PUNCH' RLSP STRING 'REAL' REMSP STRING 'REM' REMDSP STRING 'REMDR' RETSP STRING 'RETURN' REWNSP STRING 'REWIND' RPLCSP STRING 'REPLACE' RPOSSP STRING 'RPOS' RTABSP STRING 'RTAB' RTYPSP STRING 'RTNTYPE' SIZESP STRING 'SIZE' SPANSP STRING 'SPAN' STCTSP STRING 'STCOUNT' STFCSP STRING 'STFCOUNT' STLMSP STRING 'STLIMIT' STPTSP STRING 'STOPTR' STNOSP STRING 'STNO' VARSP STRING 'STRING' SUCCSP STRING 'SUCCEED' TABSP STRING 'TAB' TIMSP STRING 'TIME' TRCESP STRING 'TRACE' TRMSP STRING 'TRIM' UNLDSP STRING 'UNLOAD' VALSP STRING 'VALUE' * CRDFSP STRING '(80A1)' Default output format OUTPSP STRING '(1X,132A1)' Standard print format * * Pointers to Other Initialization * ABNDB LHERE , DESCR ALPHSP,0,0 &ALPHABET DESCR ALPHVL,0,0 DESCR CRDFSP,0,0 Default output format DESCR DFLFST,0,0 DESCR EXDTSP,0,0 'EXTERNAL' DESCR EXTPTR,0,0 DESCR ENDSP,0,0 'END' DESCR ENDPTR,0,0 DESCR FRETSP,0,0 'FRETURN' DESCR FRETCL,0,0 DESCR FUNTSP,0,0 'FUNCTION' DESCR FUNTCL,0,0 DESCR NRETSP,0,0 'NRETURN' DESCR NRETCL,0,0 DESCR RETSP,0,0 'RETURN' DTEND DESCR RETCL,0,0 BUFEXT EQU DTEND-ANYSP BUFLEN EQU BUFEXT*CPA * * System Arrays * PRMTBL DESCR PRMTBL,TTL+MARK,PRMSIZ DESCR DTLIST,0,0 Data type pair list DESCR FNLIST,0,0 Function pair list DESCR FTABLE,0,0 Procedure descriptor table DESCR ICLBLK,0,0 Miscellaneous data DESCR KNLIST,0,0 Unprotected keyword pair list DESCR KVLIST,0,0 Protected keyword pair list DESCR OPTBL,0,0 Operator procedure descriptors DESCR STACK,0,0 Interpreter stack DESCR INLIST,0,0 Input association pair list DESCR OTLIST,0,0 Output association pair list DESCR INSATL,0,0 Input block list DESCR OTSATL,0,0 Output block list DESCR TFENPL,0,0 Call trace pair list DESCR TFEXPL,0,0 Return trace pair list DESCR TKEYPL,0,0 Keyword trace pair list DESCR TLABPL,0,0 Label trace pair list DESCR TRLIST,0,0 Trace pair list DESCR TVALPL,0,0 Value trace pair list PRMTRM LHERE , End of basic block list PRMSIZ EQU PRMTRM-PRMTBL-DESCR Size of basic block list * * String Storage Bin List * OBLOCK DESCR OBLOCK,TTL+MARK,OBARY*DESCR ARRAY 3 Pseudo heading OBSTRT ARRAY OBSIZ Bin list OBLIST EQU OBSTRT-LNKFLD Pseudo link pointer * * Pattern Matching History List * PDLBLK DESCR PDLBLK,TTL+MARK,SPDLSZ*DESCR ARRAY SPDLSZ Pattern history list * * SYSTEM STACK * STACK DESCR STACK,TTL+MARK,STSIZE*DESCR ARRAY STSIZE Interpreter stack * * Primitive Patterns * ABORPT DESCR ABORPT,TTL+MARK,3*DESCR DESCR ABORFN,FNC,2 ABORT DESCR 0,0,0 DESCR 0,0,0 * ARBAK DESCR ARBAK,TTL+MARK,6*DESCR DESCR ONARFN,FNC,2 DESCR 3*DESCR,0,0 DESCR 0,0,0 DESCR ONRFFN,FNC,2 DESCR 0,0,0 DESCR 0,0,0 * ARBPT DESCR ARBPT,TTL+MARK,9*DESCR DESCR SCOKFN,FNC,2 ARB DESCR 0,0,3*DESCR DESCR 0,0,0 DESCR SCOKFN,FNC,2 DESCR 6*DESCR,0,0 DESCR 0,0,0 DESCR FARBFN,FNC,2 DESCR 6*DESCR,0,0 DESCR 0,0,0 * ARHED DESCR ARHED,TTL+MARK,12*DESCR DESCR SCOKFN,FNC,2 DESCR 0,0,3*DESCR DESCR 0,0,0 DESCR SCOKFN,FNC,2 DESCR 6*DESCR,0,0 DESCR 0,0,0 DESCR ARBNFN,FNC,2 DESCR 9*DESCR,0,12*DESCR DESCR 0,0,0 DESCR ARBFFN,FNC,2 DESCR 0,0,0 DESCR 0,0,0 * ARTAL DESCR ARTAL,TTL+MARK,6*DESCR DESCR EARBFN,FNC,2 DESCR 0,0,3*DESCR DESCR 0,0,0 DESCR SCOKFN,FNC,2 DESCR 6*DESCR,0,0 DESCR 0,0,0 * BALPT DESCR BALPT,TTL+MARK,9*DESCR DESCR SCOKFN,FNC,2 BAL DESCR 0,0,3*DESCR DESCR 0,0,0 DESCR BALFN,FNC,2 DESCR 6*DESCR,0,0 DESCR 0,0,0 DESCR BALFFN,FNC,2 DESCR 6*DESCR,0,0 DESCR 0,0,0 * FAILPT DESCR FAILPT,TTL+MARK,3*DESCR DESCR SALFFN,FNC,2 FAIL DESCR 0,0,0 DESCR 0,0,0 * FNCEPT DESCR FNCEPT,TTL+MARK,3*DESCR DESCR FNCEFN,FNC,2 FENCE DESCR 0,0,0 DESCR 0,0,0 * REMPT DESCR REMPT,TTL+MARK,4*DESCR DESCR RTBFN,FNC,3 REM DESCR 0,0,0 DESCR 0,0,0 DESCR 0,0,I * STARPT DESCR STARPT,TTL+MARK,11*DESCR DESCR STARFN,FNC,3 DESCR 0,0,4*DESCR DESCR 1,0,0 DESCR 0,0,0 DESCR SCOKFN,FNC,2 DESCR 7*DESCR,0,0 DESCR 0,0,0 DESCR DSARFN,FNC,3 DESCR 0,0,4*DESCR DESCR 0,0,0 DESCR 0,0,0 * SUCCPT DESCR SUCCPT,TTL+MARK,3*DESCR DESCR SUCFFN,FNC,2 SUCCEED DESCR 0,0,0 DESCR 0,0,0 * TVALPL DESCR TVALPL,TTL+MARK,2*DESCR DESCR 0,0,0 VALUE trace DESCR 0,0,0 TLABPL DESCR TLABPL,TTL+MARK,2*DESCR DESCR 0,0,0 LABEL trace DESCR 0,0,0 TFENPL DESCR TFENPL,TTL+MARK,2*DESCR DESCR 0,0,0 CALL trace DESCR 0,0,0 TFEXPL DESCR TFEXPL,TTL+MARK,2*DESCR DESCR 0,0,0 RETURN trace DESCR 0,0,0 TKEYPL DESCR TKEYPL,TTL+MARK,2*DESCR DESCR 0,0,0 KEYWORD trace DESCR 0,0,0 * VALBLK DESCR VALBLK,TTL+MARK,6*DESCR DESCR 0,0,S STRING DESCR 0,0,0 0 offset DESCR 0,0,N NAME DESCR 0,0,0 0 offset DESCR 0,0,K KEYWORD (NAME) DESCR 0,0,0 0 offset * * Fatal Error Message Pointers * MSGLST DESCR 0,0,0 DESCR MSG1,0,0 DESCR MSG2,0,0 DESCR MSG3,0,0 DESCR MSG4,0,0 DESCR MSG5,0,0 DESCR MSG6,0,0 DESCR MSG7,0,0 DESCR MSG8,0,0 DESCR MSG9,0,0 DESCR MSG10,0,0 DESCR MSG11,0,0 DESCR MSG12,0,0 DESCR MSG13,0,0 DESCR MSG14,0,0 DESCR MSG15,0,0 DESCR MSG16,0,0 DESCR MSG17,0,0 DESCR MSG18,0,0 DESCR MSG19,0,0 DESCR MSG20,0,0 DESCR MSG21,0,0 DESCR MSG22,0,0 DESCR MSG23,0,0 DESCR MSG24,0,0 DESCR MSG25,0,0 DESCR MSG26,0,0 DESCR MSG27,0,0 DESCR MSG28,0,0 * * Fatal Error Messages * MSG1 STRING 'ILLEGAL DATA TYPE' MSG2 STRING 'ERROR IN ARITHMETIC OPERATION' MSG3 STRING 'ERRONEOUS ARRAY OR TABLE REFERENCE' MSG4 STRING 'NULL STRING IN ILLEGAL CONTEXT' MSG5 STRING 'UNDEFINED FUNCTION OR OPERATION' MSG6 STRING 'ERRONEOUS PROTOTYPE' MSG7 STRING 'UNKNOWN KEYWORD' MSG8 STRING 'VARIABLE NOT PRESENT WHERE REQUIRED' MSG9 STRING 'ENTRY POINT OF FUNCTION NOT LABEL' MSG10 STRING 'ILLEGAL ARGUMENT TO PRIMITIVE FUNCTION' MSG11 STRING 'READING ERROR' MSG12 STRING 'ILLEGAL I/O UNIT' MSG13 STRING 'LIMIT ON DEFINED DATA TYPES EXCEEDED' MSG14 STRING 'NEGATIVE NUMBER IN ILLEGAL CONTEXT' MSG15 STRING 'STRING OVERFLOW' MSG16 STRING 'OVERFLOW DURING PATTERN MATCHING' MSG17 STRING 'ERROR IN SNOBOL4 SYSTEM' MSG18 STRING 'RETURN FROM LEVEL ZERO' MSG19 STRING 'FAILURE DURING GOTO EVALUATION' MSG20 STRING 'INSUFFICIENT STORAGE TO CONTINUE' MSG21 STRING 'STACK OVERFLOW' MSG22 STRING 'LIMIT ON STATEMENT EXECUTION EXCEEDED' MSG23 STRING 'OBJECT EXCEEDS SIZE LIMIT' MSG24 STRING 'UNDEFINED OR ERRONEOUS GOTO' MSG25 STRING 'INCORRECT NUMBER OF ARGUMENTS' MSG26 STRING 'LIMIT ON COMPILATION ERRORS EXCEEDED' MSG27 STRING 'ERRONEOUS END STATEMENT' MSG28 STRING 'EXECUTION OF STATEMENT WITH COMPILATION ERROR' * * Compiler Error Messages * EMSG1 STRING 'ERRONEOUS LABEL' EMSG2 STRING 'PREVIOUSLY DEFINED LABEL' EMSG3 STRING 'ERRONEOUS SUBJECT' EMSG14 STRING 'ERROR IN GOTO' ILCHAR STRING 'ILLEGAL CHARACTER IN ELEMENT' ILLBIN STRING 'BINARY OPERATOR MISSING OR IN ERROR' ILLBRK STRING 'ERRONEOUS OR MISSING BREAK CHARACTER' ILLDEC STRING 'ERRONEOUS REAL NUMBER' ILLEOS STRING 'IMPROPERLY TERMINATED STATEMENT' ILLINT STRING 'ERRONEOUS INTEGER' OPNLIT STRING 'UNCLOSED LITERAL' * * Formats * ALOCFL FORMAT '(40H0INSUFFICIENT STORAGE FOR INITIALIZATION)' E3.10.6 ARTHNO FORMAT '(1H0,I15,32H ARITHMETIC OPERATIONS PERFORMED)' CMTIME FORMAT '(1H0,I15,21H MS. COMPILATION TIME)' EJECTF FORMAT '(1H1)' ERRCF FORMAT '(34H0ERRORS DETECTED IN SOURCE PROGRAM/1H1)' EXNO FORMAT '(1H0,I15,21H STATEMENTS EXECUTED,,I8,7H FAILED)' FTLCF FORMAT '(6H1ERROR,I3,13H IN STATEMENT,I5,9H AT LEVEL,I3)' * E3.4.1 INCGCF FORMAT '(33H1INCOMPLETE STORAGE REGENERATION.)' INTIME FORMAT '(1H0,I15,19H MS. EXECUTION TIME)' LASTSF FORMAT '(28H LAST STATEMENT EXECUTED WAS,I5)' NODMPF FORMAT '(28H1TERMINAL DUMP NOT POSSIBLE.)' NRMEND FORMAT '(28H1NORMAL TERMINATION AT LEVEL,I3)' NVARF FORMAT '(18H0NATURAL VARIABLES,/1H )' PKEYF FORMAT '(21H0UNPROTECTED KEYWORDS/1H )' PRTOVF FORMAT '(29H ***PRINT REQUEST TOO LONG***)' READNO FORMAT '(1H0,I15,16H READS PERFORMED)' SCANNO FORMAT '(1H0,I15,26H PATTERN MATCHES PERFORMED)' SOURCF FORMAT '(42H0BELL TELEPHONE LABORATORIES, INCORPORATED,/1H1)' STATHD FORMAT '(28H1SNOBOL4 STATISTICS SUMMARY-)' STDMP FORMAT '(33H1DUMP OF VARIABLES AT TERMINATION/1H )' STGENO FORMAT '(1H0,I15,33H REGENERATIONS OF DYNAMIC STORAGE)' SUCCF FORMAT '(37H0NO ERRORS DETECTED IN SOURCE PROGRAM/1H1)' SYSCMT FORMAT '(27H0CUT BY SYSTEM IN STATEMENT,I5,9H AT LEVEL,I3)' * E3.4.1 TIMEPS FORMAT '(1H0,F15.2,35H MS. AVERAGE PER STATEMENT EXECUTED/1H1)' TITLEF FORMAT '(37H1SNOBOL4 (VERSION 3.11, MAY 19, 1975)/8H+_______)' * V3.11 WRITNO FORMAT '(1H0,I15,17H WRITES PERFORMED)' END